home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / INTERFACE / Grapher.lisp < prev    next >
Encoding:
Text File  |  1990-06-24  |  123.2 KB  |  2,584 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         Grapher.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      25-Sep-88 09:58:14
  17. ; Modified:     24-Jun-90 23:03:21 (Dan Suthers)
  18. ; Language:     LISP
  19. ; Package:      GRAPHER
  20. ;
  21. ; Description:  Draws directed graphs on the Macintosh in Allegro Common Lisp.
  22. ;               Supports a variety of graph node and layout styles.  Nodes are
  23. ;               mouse sensitive, and mouse actions can be defined.  A generic
  24. ;               grapher for SM objects is provided, which also serves as an 
  25. ;               example of its use. 
  26. ;
  27. ; (c) Copyright 1988, by Daniel D. Suthers
  28. ;                        Department of Computer and Information Science
  29. ;                        University of Massachusetts
  30. ;                        Amherst, Massachusetts 01003
  31. ;
  32. ; This software was conceived, designed, and written by Dan Suthers 
  33. ; while supported by the National Science Foundation under grant number
  34. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  35. ; CA.  Partial support was also received from the Office of Naval Research
  36. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  37. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  38. ; the above grants and encouraged me to pursue my own research interests in
  39. ; her lab.  This work would not have been possible without the resources and
  40. ; stimulating environment of the Computer and Information Science department.
  41. ;
  42. ; Permission to use, modify, and distribute this software is granted subject 
  43. ; to the following restrictions and understandings:
  44. ; 1. The file header, including this notice, shall be retained, and may be
  45. ;    extended to include documentation of modifications to the software.
  46. ; 2. This material is for nonprofit educational and research purposes only.
  47. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  48. ;    noteworthy uses of this software.
  49. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  50. ;    representation that the operation of this software will be error free,
  51. ;    and are under no obligation to provide any services.
  52. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  53. ;    Suthers and the University of Massachusetts from all claims arising 
  54. ;    out of the use or misuse of this software, or arising out of any 
  55. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  56. ;    fees, and liabilities incurred in or about any such claim, action, or
  57. ;    proceeding brought thereon.
  58. ; 5. All materials and reports developed as a consequence of the use of 
  59. ;    this software shall duly acknowledge such use, in accordance with
  60. ;    the usual standards of acknowledging credit in academic research.
  61. ;
  62. ; Status:       Stable and quite usable, though the programmer's interface is
  63. ;               rather low level, and the code is ugly in places.
  64. ;
  65. ; Changes:
  66. ;   24-Jul-88 NIL now represents the null graph view; added clear-graph-view.
  67. ;   08-Aug-88 Adding mouse sensitivity and associated operations.
  68. ;   04-Sep-88 Nodes now moved by holding mouse down.
  69. ;   16-Sep-88 Windows now have grow boxes (usually hidden by clear).
  70. ;   22-Sep-88 Better Menu, more control over SM graphs, eliminated
  71. ;     clear-graph-window, backlinks attach at better points.
  72. ;   24-Sep-88 Generalizing mouse methods: the slot is now an alist of
  73. ;     symbolic option names to (lambda (view node) ...) methods.
  74. ;   22-Oct-88 Cleaned up SM grapher; using oval and round-rect for node
  75. ;     status. Added mouse method for updating when SM instances change.
  76. ;   01-Nov-88 A graph-view which is about to be destroyed is not redrawn
  77. ;     when the mouse-methods menu dissappears, exposing the graph window.
  78. ;     This keeps the user from having to wait for superfluous redraws.
  79. ;   04-Nov-88 Added :frame and :round-frame node styles for multiple labels.
  80. ;     Backup to Parent View mouse method restores gv to gw if there is no
  81. ;     parent view (bug introduced 01-Nov which set gv to nil).
  82. ;   06-Nov-88 Fixed longstanding bug that vertical alignment was off in 
  83. ;     :vertical-tree style ... box-size was not being updated in a loop.
  84. ;   08-Nov-88 Efficiency improvements. "Magic Numbers" declared as constants.
  85. ;   09-Dec-88 Multiple-menu choice on recompute layout.
  86. ;   16-Dec-88 Mouse methods now compiled (but SAVE-GRAPH-VIEW can't save them).
  87. ;   31-Dec-88 WINDOW-DRAW-CONTENTS retains selected-node, and highlights
  88. ;     it correctly, eliminating problem with redraw after popup dialogues.
  89. ;     Eliminated GRAPH-NODE-PARENTS.  Fixed "NIL is an invalid point" problem
  90. ;     when recomputing layout of radials.  (The layout was being changed
  91. ;     while the window was still redrawing where the grapher menu was. Put 
  92. ;     in time delay on all menu items changing layout to let this complete.)
  93. ;   15-Jan-89 GRAPH-SM-OBJECTS and SM-TYPE->GRAPH-VIEW now have optional
  94. ;     argument which lets you specify how to compute graph node labels.
  95. ;   22-Sep-89 Added require of SMEDIT, since EDITS used. 
  96. ;   25-Oct-89 Windows now automatically layout & redraw graph when resized.
  97. ;   26-Oct-89 Mouse action menus now have first item selected as default.
  98. ;   30-Oct-89 Inspect Structure added to SM Mouse Methods.  GRAPH-SM-OBJECTS
  99. ;     menu item now checks sm:type-info for :graph-view-roots and for 
  100. ;     :graph-view-child-slot or :graph-view-parent-slot before asking.
  101. ;   01-Nov-89 Added :none-frame graph node box style.
  102. ;   08-Nov-89 Added default mouse method to show graph view parameters.
  103. ;   21-Dec-89 Mouse-method popups now come in upper left of the window.
  104. ;     Exported two macros to help others do this: UPPER-LEFT-POPUP-POSITION
  105. ;     and WITH-UPPER-LEFT-POPUP.  Relies on change made to DIALOGE.lisp today. 
  106. ;     Fixed error when graph-view-parameter-dialog has null table sequences.
  107. ;   02-Jan-90 Fixed run-mouse-method to accept double clicks in menu.  
  108. ;     Added * versions of layout style, which put all childless nodes in
  109. ;     the first layer before starting the tree in the next layer.  Outlines
  110. ;     now drawn every half second when moving nodes; was too slow.
  111. ;   11-Jan-90 Mouse menu now shows 7 items for faster selection, and is 
  112. ;     labeled with object rather than graph node if the object is available.
  113. ;   23-Jan-90 Graph view parameters now in document dialog.
  114. ;   29-Jan-90 Updated for version 1.3.1.  WINDOW-DRAW-CONTENTS -> VIEW-...;
  115. ;     :default-button specified in button item.
  116. ;   12-Feb-90 Zoom box added to graph windows.
  117. ;   15-Mar-90 Added interpretation of arrow keys to move up and down in
  118. ;     graphs that have mouse methods for this.  Very bogus implementation,
  119. ;     this whole thing needs rewriting in object oriented style!
  120. ;   26-Apr-90 DS Fixed bug in layout where all level-1 nodes were pushed
  121. ;     down deeper, leaving the first level empty.  Now it checks for this
  122. ;     and shifts all the nodes up one level if needed. 
  123. ;     Attachment points are now computed nicely depending on relative 
  124. ;     position of nodes rather than relative layering.
  125. ;     Also, *STARRED-STYLES* and *FRAMED-STYLES* parameterized.
  126. ;   08-May-90 DS Finally figured out an easy way to reduce link crossings;
  127. ;     added an ordering style which does this.
  128. ;   24-Jun-90 DS WITH-UPPER-LEFT-POPUP macro not being expanded when mouse
  129. ;     methods compiled -- too lazy to figure out why; replaced with LET.
  130. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  131. #|
  132.  
  133. Guide to the Perplexed:
  134.  
  135. We have found this grapher to be extremely useful in a variety of 
  136. applications, including graphing concept hierarchies; frames linked by 
  137. the slots between them; traces of rule-based reasoners; "DACTNs", which
  138. are graphical representations of discourse generation procedures; and
  139. in graphing various data structures generated by Artificial Intelligence
  140. programs we are writing in the areas of Explanation and Tutoring Systems.
  141.  
  142. However, you are warned that
  143.  * It is coded in a mixture of CCL objects for windows and SM structures
  144.    for graph "views" and "nodes", and is not as clean as a purely object
  145.    oriented program.  (In short, the code is wierd.)
  146.  * The programmer's interface is low level, and it may take a bit of 
  147.    effort to understand it at first.  You must first understand the SM
  148.    package for managing Common Lisp structures.
  149.  * I have not had time to write a user's manual, other than the following.
  150.  
  151. This grapher differs from most in that it tries to fit the entire graph
  152. into the window.   (Most graphers layout the graph in as much virtual space
  153. as is needed, and then use a scrollable window which displays only part of
  154. the graph if the graph is too large to fit.)   My justification is that this
  155. grapher was intended to be used with applications which are "intelligent"
  156. enough to select digestable quantities of information, rather than 
  157. overwhelming the user with a huge graph.  Navigation through the graph
  158. is done by selecting commands on dialog menus which move from one meaningful
  159. "view" to another, rather than by simulating physical movement of a large 
  160. sheet of paper under a window.
  161.  
  162. Please take the time to read the documentation in the SM.lisp file.
  163.  
  164. Graphs are displayed in windows of type *graph-window*.  Each *graph-window*
  165. has an object variable GRAPH-VIEW.  This is bound to either NIL for an
  166. empty window, or to the name of an SM structure instance of type GRAPH-VIEW.
  167. *Graph-window*s know how to translate graph-view structures into the displayed
  168. graph.  Internally, graphs consist of GRAPH-NODEs, which include labels and
  169. links to other graph-nodes.  However, as mentioned above, not all of a given
  170. graph is displayed at a given time.  A graph-view specifies what part of the
  171. graph should be drawn.  As my SM documentation puts it:
  172.  
  173. A Graph-View is a view (way of drawing graphically) a portion of a graph
  174. (collection of Graph-Nodes).  A given Graph-Node may participate in multiple
  175. Graph-Views, and a given graph may have multiple views on it.  The Graph-View
  176. is specified in terms of the Graph-Nodes which are the Roots to search the
  177. graph from, the Depth-Bound of this search, the Style of laying out the found
  178. graph, and the Ordering used to layout children of a given node.
  179.  
  180. A Graph-Node is how you specify the label, children, and box style of a vertex of 
  181. the graph to be drawn.  It also contains computed, graph-independent information 
  182. concerning the size of the box which is needed to draw the node, and where edge 
  183. attachments may be made to it.
  184.  
  185. See the SM documentation of this structure in this file for further information
  186. on graph-view Style, Ordering, etc., and on the box styles for graph-nodes.
  187. Generally, you can have styles of horizontal and vertical tree or radial layout;
  188. ordering can be as found, reversed, or reordered to attempt to reduce link
  189. crossings; and nodes can be ovals, rectangles, rounded rectangles, no box at
  190. all, or frames, which are multi-line versions of rectangles.
  191.  
  192. What all this means for you is in order to use the grapher, you have to write
  193. code that:
  194.  - generates a collection of graph-nodes, including labels and links.
  195.  - creates a graph-view structure specifying how the graph is displayed
  196.  - creates an instance of *graph-window* with the graph-view object variable
  197.    bound to the graph-view structure.
  198. If you want to have special commands which operate on the graph when a node
  199. is mouse-selected, you also need to give the *graph-window* a command list
  200. such as *sm-mouse-methods*, in this file. 
  201.  
  202. This brings me to GRAPH-SM-OBJECTS and associated code.  Please see the
  203. section of this file which includes that function.  It exemplifies how I
  204. use this grapher.  
  205.  
  206. For a quick look at the grapher, load the demo file Grapher-Demo.lisp.
  207. Play with the mouse, try the menu options, notice how the links change
  208. position when you move nodes around, and change the window size to get
  209. a feel for its behavior.
  210.  
  211. -- Dan Suthers
  212.  
  213. |#
  214. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  215.  
  216. (in-package :GRAPHER)
  217.  
  218. (require :SM)
  219. (require :SMEDIT)    ; edits
  220. (require :DIALOGUE)
  221. (require :CONTROL)   ; random-choice
  222. (require :MAPPINGS)  ; image
  223. (require :MATH)      ; radians
  224. (require :MISC)      ; unique-symbol, etc.
  225.  
  226. (require :quickdraw "ccl;LIBRARY:QuickDraw")
  227. (use-package :CCL)
  228.  
  229. (export '(
  230.           *graph-window*
  231.           graph-sm-objects
  232.           graph-view-parameter-dialogue
  233.           sm-type->graph-view
  234.           windows-using-graph-view
  235.  
  236.           ;; Window functions
  237.           layout-graph-view
  238.           move-node
  239.           set-graph-view
  240.  
  241.           create-graph-view
  242.           dispose-graph-view
  243.           graph-view
  244.           graph-view-roots
  245.           graph-view-style
  246.           graph-view-ordering
  247.           graph-view-depth-bound
  248.           graph-view-node-font
  249.           graph-view-text-font
  250.           graph-view-border-width
  251.           graph-view-mouse-methods
  252.           graph-view-info
  253.           graph-view-info-image
  254.           save-graph-view
  255.  
  256.           create-graph-node
  257.           graph-node
  258.           graph-node-object
  259.           graph-node-box-style
  260.           graph-node-children
  261.           graph-node-connector
  262.           graph-node-label
  263.  
  264.           upper-left-popup-position
  265.           with-upper-left-popup
  266.  
  267.           ))
  268.  
  269. ;;; Best default for Allegro CL -- see manual's implementation notes.
  270. ;;; - The safety 1 space 2 speed 2 setting lets the compiler trust all
  271. ;;; type declarations, and eliminates event-processing in iterative loops.
  272. ;;; - We crank this up to safety 1 space 2 speed 3 for heavy computation,
  273. ;;; so fixnum operations are guaranteed to return fixnums, and car and
  274. ;;; cdr don't check types (but an error would crash Allegro).
  275. ;;; - A drop to safety 0 would eliminate number of argument and stack 
  276. ;;; overflow checks, skip some event processing, and make slot access 
  277. ;;; open coded with no type checking.  Timing tests show moderate gains.
  278.  
  279. (proclaim '(optimize (safety 1) (space 2) (speed 2)))
  280.  
  281. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  282. ;;;
  283. ;;;                    MAGIC NUMBERS AND OTHER PARAMETERS
  284. ;;;
  285. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  286. ;;; This does not contain all parameters -- just those which occur in 
  287. ;;; disjoint places, and thus would be hard to update, and some which 
  288. ;;; occur localized but are likely to be modified.
  289.  
  290. (defconstant *STARRED-STYLES* '(:horizontal-tree* :vertical-tree* :radial*)
  291.   "Graph view styles which put childess nodes alone in the first layer.")
  292.  
  293. (defconstant *FRAMED-STYLES* '(:frame :round-frame :none-frame)
  294.   "Graph node styles which can have multiple lines.")
  295.  
  296. ;;; Points to indent from edge of screen to windows.
  297. (defconstant *SCREEN-EDGE-INDENTATION* 2)
  298.  
  299. ;;; Font size must be smaller than this to be called "small".
  300. (defconstant *SMALL-FONT-THRESHOLD* 10) 
  301.  
  302. ;;; How much to pad the box-height beyond the actual height in points of the font.
  303. ;;; More padding is needed for ovals.
  304. (defconstant *SMALL-FONT-BOX-HEIGHT-PADDING* 2) 
  305. (defconstant *LARGE-FONT-BOX-HEIGHT-PADDING* 4) 
  306. (defconstant *SMALL-FONT-OVAL-BOX-HEIGHT-PADDING* 6)
  307. (defconstant *LARGE-FONT-OVAL-BOX-HEIGHT-PADDING* 8)
  308.  
  309. ;;; How much to pad the box-width beyond the width of the text in points to 
  310. ;;; ensure adequate space between the box and the text.  A function of box 
  311. ;;; shape since some shapes "slope in", requiring more padding to clear text.
  312. (defconstant *RECT-BOX-WIDTH-PADDING* 5)
  313. (defconstant *ROUND-RECT-BOX-WIDTH-PADDING* 13)
  314. (defconstant *ROUND-FRAME-BOX-WIDTH-PADDING* 23)
  315. (defconstant *OVAL-BOX-WIDTH-PADDING* 25)
  316.  
  317. ;;; How much to indent the text from the box's origin in the H and V dimensions.
  318. ;;; H indentation a function of box shape for reasons indicated above.
  319. (defconstant *RECT-TEXT-H-INDENTATION* 3)
  320. (defconstant *ROUND-RECT-TEXT-H-INDENTATION* 7)
  321. (defconstant *ROUND-FRAME-TEXT-H-INDENTATION* 12)
  322. (defconstant *OVAL-TEXT-H-INDENTATION* 13)
  323. (defconstant *SMALL-FONT-V-TEXT-INDENTATION* 4)
  324. (defconstant *LARGE-FONT-V-TEXT-INDENTATION* 5)
  325.  
  326. ;;; How different the H (or V) coordinates of two boxes have to be apart before 
  327. ;;; one is considered to be to the left or right (above or below) the other, 
  328. ;;; rather than in the same position in that dimension.  Affects which side the 
  329. ;;; links are connected on.
  330. (defconstant *RELATIVE-H-POSITION-THRESHOLD* 50) ; roughly average node width?
  331. (defconstant *RELATIVE-V-POSITION-THRESHOLD* 15) ; roughly average node height.
  332.  
  333. ;;; Radius of the circular blob drawn to mark the connection point of a link.
  334. (defconstant *CONNECTOR-RADIUS* 3)
  335.  
  336. ;;; How far away you can click from a selected node and still count as a double 
  337. ;;; click.  Should be more lenient than usual Mac 4 pixels, since graph nodes
  338. ;;; have larger extent.
  339. (defconstant *GRAPH-WINDOW-DOUBLE-CLICK-SPACING* 20)
  340.  
  341. ;;; How long before a mouse held down is counted as such, to ensure user means it.
  342. (defconstant *GRAPH-WINDOW-MOUSE-DOWN-DELAY* 0.3)
  343.  
  344. (defconstant *OUTLINE-TIME-INTERVAL* 
  345.   (truncate (/ internal-time-units-per-second 2)))
  346.  
  347.  
  348. ;;; Special Handling of mouse methods on *mouse-methods-replacing-graph-view*
  349. ;;; prevents the re-drawing of the current graph view by view-draw-contents
  350. ;;; when the menu dialogue by which the method is selected dissappears (exposing
  351. ;;; part of the window). This saves the user from having to wait for redraw of 
  352. ;;; complicated graphs which are about to be replaced anyway.
  353.  
  354. (defparameter *MOUSE-METHODS-REPLACING-GRAPH-VIEW* 
  355.   '("Make this Node the Root" 
  356.     "Backup Once to Parent View" 
  357.     "Update Graph View for Changes"
  358.     "Backup All the Way to Original View"))
  359.  
  360. ;;; Added to a window's position to get where mouse-generated popups should appear.
  361. (defconstant *POPUP-OFFSET* (make-point 10 10))
  362.  
  363. ;;; Things to make it easy to get window-relative upper left popups.
  364.  
  365. (defmacro UPPER-LEFT-POPUP-POSITION (w)
  366.   `(ask ,w (add-points (window-position) *popup-offset*)))
  367.  
  368. (defmacro WITH-UPPER-LEFT-POPUP (w &rest body)
  369.   `(let ((wind:*dialogue-position* 
  370.           (ask ,w (add-points (window-position) *popup-offset*))))
  371.      ,@body))
  372.  
  373. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  374. ;;;
  375. ;;;                             DATA STRUCTURES
  376. ;;;
  377. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  378.  
  379. ;;; Vertices.  A set of these implicitly define a DAG by virtue of their 
  380. ;;; children pointers.
  381.  
  382. (sm:dst (GRAPH-NODE 
  383.          (:reusable t)
  384.          (:comments "
  385.   A Graph-Node is how you specify the label, children, and box style of a vertex of 
  386.   the graph to be drawn.  It also contains computed, graph-independent information 
  387.   concerning the size of the box which is needed to draw the node, and where edge 
  388.   attachments may be made to it."))
  389.  
  390.         (LABEL         ""
  391.                        :type (or string list)
  392.                        :comments "
  393.     The string labeling the node.  Make it short!  If BOX-STYLE is :frame,
  394.     :round-frame, or :none-frame this must be a list of strings, which will
  395.      be displayed on separate lines in a multi-line graph node.")
  396.  
  397.         (CHILDREN      nil 
  398.                        :type list
  399.                        :comments "
  400.     A list of Graph-Node names of the children of the present node.")
  401.  
  402.         (BOX-STYLE     :rect
  403.                        :type (member :none :rect :round-rect :oval 
  404.                                      :none-frame :frame :round-frame)
  405.                        :comments "
  406.     Indicates what sort of box to draw around the label, if any, and whether there
  407.     are multiple labels (see comments for LABEL).")
  408.  
  409.         (CONNECTOR     T
  410.                        :type (member t nil)
  411.                        :comments "
  412.     Indicates whether to draw a round 'connector' where the arc meets the node box.")
  413.                        
  414.         (OBJECT        nil 
  415.                        :comments "
  416.     The application may store here arbitrary information, presumably a pointer to
  417.     the application object which this graph node corresponds to.")
  418.  
  419.         (BOX-SIZE      0 
  420.                        :type fixnum
  421.                        :computed t
  422.                        :comments "
  423.     A Macintosh Point indicating the size of the box drawn around the label.")
  424.  
  425.         (TOP-CENTER    0 
  426.                        :type fixnum
  427.                        :computed t
  428.                        :comments "
  429.     A Macintosh Point indicating the offset from the position of the node box to
  430.     the center of the Top edge of the box.")
  431.  
  432.         (BOTTOM-CENTER 0   
  433.                        :type fixnum
  434.                        :computed t
  435.                        :comments "
  436.     A Macintosh Point indicating the offset from the position of the node box to
  437.     the center of the Bottom edge of the box.")
  438.  
  439.         (LEFT-CENTER   0 
  440.                        :type fixnum
  441.                        :computed t
  442.                        :comments "
  443.     A Macintosh Point indicating the offset from the position of the node box to
  444.     the center of the Left edge of the box.")
  445.  
  446.         (RIGHT-CENTER  0
  447.                        :type fixnum
  448.                        :computed t
  449.                        :comments "
  450.     A Macintosh Point indicating the offset from the position of the node box to
  451.     the center of the Right edge of the box.")
  452.  
  453.         (CENTER        0
  454.                        :type fixnum
  455.                        :computed t
  456.                        :comments "
  457.     A Macintosh Point indicating the offset from the position of the node box to
  458.     the center of the box.  Mouse sensitivity is computed relative to this."))
  459.  
  460. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  461.  
  462. (sm:dst (GRAPH-VIEW 
  463.          (:reusable nil)
  464.          (:sort-instances t)
  465.          (:comments "
  466.   A Graph-View is a view (way of drawing graphically) a portion of a graph
  467.   (collection of Graph-Nodes).  A given Graph-Node may participate in multiple
  468.   Graph-Views, and a given graph may have multiple views on it.  The Graph-View
  469.   is specified in terms of the Graph-Nodes which are the Roots to search the
  470.   graph from, the Depth-Bound of this search, the Style of laying out the found
  471.   graph, and the Ordering used to layout children of a given node.  Not reusable
  472.   since the members list should be reclaimed."))
  473.  
  474.         (ROOTS       nil
  475.                      :type list
  476.                      :comments "
  477.     A list of Graph-Nodes from which to search in constructing the view.")
  478.  
  479.         (DEPTH-BOUND 9
  480.                      :type (integer 0 *)
  481.                      :comments "
  482.     How deep from the roots to search in the graph to construct the view.")
  483.  
  484.         (STYLE       :horizontal-tree*
  485.                      :type (member :horizontal-tree :vertical-tree
  486.                                    :horizontal-tree* :vertical-tree*
  487.                                    :radial :radial*)
  488.                      :comments "
  489.     A keyword indicating the style in which the graph is drawn.")
  490.  
  491.         (ORDERING    :reduce-crossings
  492.                      :type (member :as-found :reverse-as-found
  493.                                    :reduce-crossings :reverse-reduce-crossings)
  494.                      :comments "
  495.     Keyword indicationg how to order the children of a node in the graph.")
  496.  
  497.         (NODE-FONT    '("monaco" 9)
  498.                      :type list
  499.                      :comments "
  500.     Font for labeling the node boxes.")
  501.  
  502.         (TEXT-FONT   '("chicago" 12)
  503.                      :type list
  504.                      :comments "
  505.     Font used when writing text into the graph window (other than node labels).")
  506.  
  507.         (BORDER-WIDTH 10
  508.                       :type fixnum
  509.                       :comments "
  510.     This many points are left white as leading edge before drawing.")
  511.  
  512.         (INFO        nil
  513.                      :type t
  514.                      :comments "
  515.     User may place comments, derivation trace, or other info here.")
  516.  
  517.         (MOUSE-METHODS
  518.          '(("Show Graph View Parameters"
  519.             . (lambda (gw gv gn)
  520.                 (let ((gv-struct (sm:gets 'graph-view gv))
  521.                       (*print-case* :downcase))
  522.                   (oneof *dialog*
  523.                          :window-title (format nil "~S Graph View Parameters" gv)
  524.                          :window-position (add-points (make-point 10 10)
  525.                                                       (ask gw (window-position)))
  526.                          :window-size #@(570 280)
  527.                          :window-type :document
  528.                          :default-button nil
  529.                          :close-box-p t
  530.                          :dialog-items
  531.                          (list
  532.                           (oneof *editable-text-dialog-item*
  533.                                  :dialog-item-text 
  534.                                  (format nil "Parameters for Graph View ~S ...~%~
  535.                                               ~%* ROOTS: ~S~
  536.                                               ~%* DEPTH BOUND: ~S~
  537.                                               ~%* STYLE: ~S~
  538.                                               ~%* ORDERING: ~S~
  539.                                               ~%* INFO:~%  (~{~S~%   ~})"
  540.                                          gv
  541.                                          (graph-view-roots gv-struct)
  542.                                          (graph-view-depth-bound gv-struct)
  543.                                          (graph-view-style gv-struct)
  544.                                          (graph-view-ordering gv-struct)
  545.                                          (graph-view-info gv-struct))
  546.                                  :dialog-item-position #@(5 5)
  547.                                  :dialog-item-size #@(560 270)
  548.                                  :allow-returns nil))))))
  549.            ("Inspect Associated Object"
  550.             . (lambda (gw gv gn)
  551.                       (inspect (graph-node-object (sm:gets 'graph-node gn)))))
  552.            ("Inspect Graph Node Itself"
  553.             . (lambda (gw gv gn)
  554.                       (inspect (sm:gets 'graph-node gn)))))
  555.          :type T
  556.          :comments "
  557.     The Mouse-Methods may be either a functional object of three arguments, or an 
  558.     association list.  If a function, it is called on the graph-window, graph-view,
  559.     and graph-node involved in the mouse click.  Association lists should map labels
  560.     (symbols or strings) to mouse methods, which are lambdas of three arguments (to
  561.     be given the same arguments as for the functions).  When the user clicks twice on 
  562.     a node, a menu of the domain of the alist is put up, and the lambda which is the 
  563.     image of the selected item is called.  The lambdas may be compiled, but they are
  564.     not saved by SAVE-GRAPH-VIEW.  (The default methods are not compiled, and are
  565.     saved by that function.)")
  566.  
  567.         (MEMBERS     nil
  568.                      :type list  
  569.                      :computed t
  570.                      :comments "
  571.     Association list of Graph-Nodes to CL node-placement structures, which say how
  572.     deep the node is in the DAG, and where to place it on the screen.  Also defines
  573.     who is in the Graph-View.")
  574.  
  575.         (LEVELS      0                
  576.                      :type (integer 0 *)
  577.                      :computed t
  578.                      :comments "
  579.     How deep the graph goes beyond the root nodes (<= depth bound)."))
  580.  
  581. ;;; This defines the placement of a graph-node in a view.  These records
  582. ;;; are accessed as the image of a graph node in a graph-view-members list.
  583. ;;; Totally computed, so need not use SM.
  584.  
  585. (defstruct (NODE-PLACEMENT (:type vector))
  586.   (level    0   :type integer)  ; depth + 1 in the DAG for this view
  587.   (position 0   :type integer)  ; position to be printed in *graph-window*
  588.   (quadrant      :na            ; in reference to diagonal axes
  589.                  :type (member :na :upper :lower :left :right)))
  590.  
  591. (defmacro GRAPH-VIEW-INFO-IMAGE (key gv)
  592.   `(cdr (assoc ,key (graph-view-info (sm:gets 'graph-view ,gv)))))
  593.  
  594. (defun DISPOSE-GRAPH-VIEW (graph-view)
  595.   "dispose-graph-view                                            [Function]
  596.   Destroys the graph view indicated, including any known graph-node members
  597.   of the view which are not being used elsewhere.  Checks for whether 
  598.   graph-node members have already been destroyed.  Non-nil if disposed."
  599.   (when (sm:gets 'graph-view graph-view)
  600.     (let ((members (graph-view-members (sm:gets 'graph-view graph-view))))
  601.       (declare (list members) (optimize (safety 1) (space 2) (speed 3)))
  602.       ;; This is done as soon as possible so gone if error leaves it in bad state.
  603.       (sm:destroys 'graph-view graph-view)
  604.       (dolist (gn+pos members) (declare (cons gn+pos))
  605.         (let ((gn (car gn+pos))) (declare (symbol gn))
  606.           ;; Watch for already-deleted members
  607.           (if (sm:gets 'graph-node gn)
  608.             ;; Don't delete if being used by another graph-view
  609.             (unless (dolist (gv (sm:instances 'graph-view)) (declare (symbol gv))
  610.                       (if (assoc gn (graph-view-members (sm:gets 'graph-view gv)))
  611.                         (return T)))
  612.               (sm:destroys 'graph-node gn))))))
  613.     graph-view))
  614.  
  615. ;;; The price of shared external graph nodes is all this looking around to see
  616. ;;; who I can collect.  Provide this function for external use.
  617.  
  618. (defun GRAPH-VIEWS-USING-GRAPH-NODE (gn &aux (results nil))
  619.   (dolist (gv (sm:instances 'graph-view))
  620.     (declare (symbol gv) (optimize (safety 1) (space 2) (speed 3)))
  621.     (if (assoc gn (graph-view-members (sm:gets 'graph-view gv)))
  622.       (push gv results)))
  623.   results)
  624.  
  625. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  626. ;;;
  627. ;;;                 GRAPH WINDOW OBJECTS & BASIC METHODS
  628. ;;;
  629. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  630.  
  631. (defobject *GRAPH-WINDOW* *window*)
  632.  
  633. (defobfun (EXIST *graph-window*) (init-list)
  634.   (declare (object-variable graph-view))
  635.   (let ((graph-view (getf init-list :graph-view nil)))
  636.     (check-type graph-view symbol)
  637.     ;; These must be done first in case :window-show is specified T by user.
  638.     ;; That would cause drawing to occur, which expects these to be "had".
  639.     (have 'graph-view graph-view)
  640.     (have 'selected-node nil)
  641.     ;; Usual-exist should not show the window because layout has not been
  642.     ;; computed yet.  Cannot compute layout before usual-exist, because wptr
  643.     ;; is not bound yet.  So: usual-exist without show; do layout; then show.
  644.     (usual-exist
  645.      (init-list-default
  646.       init-list
  647.       :window-title    (sm:prints 'graph-view graph-view :style :name :stream nil)
  648.       :window-position (make-point *screen-edge-indentation*  *menubar-bottom*)
  649.       :window-size     (make-point (- *screen-width* 
  650.                                       (* 2 *screen-edge-indentation*))
  651.                                    (- *screen-height* *menubar-bottom* 
  652.                                       *screen-edge-indentation*))
  653.       :window-show      nil
  654.       :window-font     '("monaco" 9)
  655.       :window-type     :document-with-zoom
  656.       :close-box       t))
  657.     (layout-graph-view)
  658.     ;; The desired behavior is default of show T, but user can override
  659.     ;; whether shown at all.  Unfortunately, if user specifies show T
  660.     ;; explicitly, it will be shown before layout in usual-exist.
  661.     (if (getf init-list :window-show t) (window-show))
  662.     ;; Return object created.
  663.     (self)))
  664.  
  665. (defobfun (SET-GRAPH-VIEW *graph-window*) (view-asked-for &key (layout t))
  666.   "set-graph-view <view-asked-for> &key <layout>       [Graph Window Function]
  667.   Sets the graph view associated with the window.  Computes its layout,
  668.   unless <layout> is nil. Does not select or redraw the window."
  669.   (declare (object-variable graph-view selected-node))
  670.   (if view-asked-for ; NIL is allowed.
  671.     (assert (sm:gets 'graph-view view-asked-for) (view-asked-for)
  672.             "[SET-GRAPH-VIEW] Unknown graph view ~S" view-asked-for))
  673.   (setq graph-view view-asked-for)
  674.   (setq selected-node nil)
  675.   ;; Layout must be (re)computed to fit this window.
  676.   (if layout (layout-graph-view))
  677.   view-asked-for)
  678.  
  679. (defobfun (SET-WINDOW-SIZE *graph-window*) (new-size)
  680.   "set-window-size                                    [Graph Window Function]
  681.   Calls usual set-window-size, but then redoes the layout of its graph 
  682.   view and recalls view-draw-contents.  In order to prevent the view
  683.   from being drawn twice, binds the graph-view to nil during the set,
  684.   since it also calls view-draw-contents.  Selected-node is reset."
  685.   (declare (object-variable graph-view selected-node))
  686.   (check-type new-size fixnum)
  687.   ;; Check for bad graph view (may have been destroyed).
  688.   (if (null (sm:gets 'graph-view graph-view))
  689.     (setf graph-view nil))
  690.   ;; Bind graph view to nil to prevent drawing, and change size by
  691.   ;; calling usual function.
  692.   (let ((graph-view nil))
  693.     (funcall (ask *window* (symbol-function 'set-window-size)) new-size))
  694.   ;; Reset selected node; then do layout and drawing.
  695.   (setq selected-node nil)
  696.   (layout-graph-view)
  697.   (view-draw-contents))
  698.  
  699. (defobfun (WINDOW-SELECT *graph-window*) ()
  700.   "window-select                                       [Graph Window Function]
  701.   Selects the window, and if there is a non-nil graph-view, draws it (via
  702.   view-draw-contents).  No node will be selected.  If the window names
  703.   a graph view which no longer exists, the window's view is set to nil."
  704.   (declare (object-variable graph-view selected-node))
  705.   ;; Check for bad graph view (may have been destroyed).
  706.   (if (null (sm:gets 'graph-view graph-view))
  707.     (setf graph-view nil))
  708.   ;; Reset selected node, and invoke usual method, which calls 
  709.   ;; view-draw-contents.
  710.   (setq selected-node nil)
  711.   (funcall (ask *window* (symbol-function 'window-select))))
  712.  
  713. (defun WINDOWS-USING-GRAPH-VIEW (target-graph-view &aux (result ()))
  714.   (declare (object-variable graph-view) (optimize (safety 1) (space 2) (speed 3)))
  715.   (dolist (w (windows *graph-window*))
  716.     (if (ask w (eq target-graph-view graph-view))
  717.       (push w result)))
  718.   result)
  719.  
  720. ;;; Closeness of click to node measured using this.
  721.  
  722. (eval-when (eval compile)
  723.   (defmacro MANHATTAN-DISTANCE (arg1 arg2)
  724.     ;; The manhattan distance is how far you walk on a discrete grid to get from
  725.     ;; one point to another.  It is more efficient to compute than euclidean
  726.     ;; distance, and, when distances are needed for comparative purposes only,
  727.     ;; just as good.
  728.     `(let ((point1 ,arg1) (point2 ,arg2))
  729.        (declare (fixnum point1 point2) (optimize (safety 1) (space 2) (speed 3)))
  730.        (+ (abs (- (point-h point1) (point-h point2)))
  731.           (abs (- (point-v point1) (point-v point2))))))
  732.   )
  733.  
  734. ;;; This has to be a function!  When macro expansion includes object variable
  735. ;;; (graph-view), things are unpredictable.  Believe it or not, sometimes the
  736. ;;; variable was accessed correctly, and sometimes it yielded NIL.
  737.  
  738. (defun RUN-MOUSE-METHOD (gw gv gn)
  739.   (declare (object-variable graph-view))
  740.   (let ((mouse-methods (graph-view-mouse-methods (sm:gets 'graph-view gv))))
  741.     (if (typep mouse-methods 'function) 
  742.       (funcall mouse-methods gw gv gn)
  743.       ;; Here we home-brew a menu so we can avoid redraw if needed.
  744.       (let* ((message-item
  745.               (oneof *static-text-dialog-item*
  746.                      :dialog-item-text 
  747.                      (format nil "What do you want to do with ~S?"
  748.                              (let ((gn-object (graph-node-object 
  749.                                                (sm:gets 'graph-node gn))))
  750.                                (if gn-object gn-object gn)))
  751.                      :dialog-item-size (make-point 450 22)))
  752.              (menu-item
  753.               (oneof *sequence-dialog-item*
  754.                      :dialog-item-position (make-point 5 32)
  755.                      :dialog-item-size  (make-point 350 142)
  756.                      :cell-size         (make-point 350 16)
  757.                      :table-vscrollp t
  758.                      :visible-dimensions  (make-point 1 7)
  759.                      :table-sequence (mapcar #'car mouse-methods)
  760.                      :dialog-item-action
  761.                      #'(lambda ()
  762.                          (if (double-click-p)
  763.                            (if (selected-cells)
  764.                              (let ((act (cell-contents (first (selected-cells)))))
  765.                                ;; Nullify graph view if it is about to be destroyed.
  766.                                (if (member act *mouse-methods-replacing-graph-view*
  767.                                            :test #'equal)
  768.                                  (ask gw (setq graph-view nil)))
  769.                                (return-from-modal-dialog act))
  770.                              (ed-beep))))))
  771.              (ok-button
  772.               (oneof *button-dialog-item*
  773.                      :dialog-item-text " OK "
  774.                      :dialog-item-position 
  775.                      (make-point 405 42)
  776.                      :dialog-item-action 
  777.                      #'(lambda ()
  778.                          (ask menu-item 
  779.                            ;; This code duplicates menu-item action.
  780.                            (if (selected-cells)
  781.                              (let ((act (cell-contents (first (selected-cells)))))
  782.                                ;; Nullify graph view if it is about to be destroyed.
  783.                                (if (member act *mouse-methods-replacing-graph-view*
  784.                                            :test #'equal)
  785.                                  (ask gw (setq graph-view nil)))
  786.                                (return-from-modal-dialog act))
  787.                              (ed-beep))))
  788.                      :default-button t))
  789.              (cancel-button
  790.               (oneof *button-dialog-item*
  791.                      :dialog-item-text "CANCEL"
  792.                      :dialog-item-position
  793.                      (make-point 395 82)
  794.                      :dialog-item-action
  795.                      #'(lambda () (return-from-modal-dialog :cancel))))
  796.              (the-dialogue
  797.               (oneof *dialog*
  798.                      :window-title "Mouse Method Menu Dialogue"
  799.                      :window-position (upper-left-popup-position gw)
  800.                      :window-size (make-point 480 170)
  801.                      :window-show t
  802.                      :window-type :double-edge-box
  803.                      :dialog-items (list ok-button cancel-button message-item menu-item))))
  804.         ;; Select a default action.
  805.         (ask menu-item (cell-select (index-to-cell 0)))
  806.         ;; Get the action: execute it.
  807.         (funcall (cdr (assoc (modal-dialog the-dialogue) mouse-methods :test #'equal)) 
  808.                  gw gv gn)))))
  809.  
  810. (defobfun (ccl::WINDOW-CLICK-EVENT-HANDLER *graph-window*) (mouse-position)
  811.   (declare (fixnum mouse-position)
  812.            (object-variable graph-view selected-node))
  813.   ;; Actions are specific to graph views, so we don't process unless there is a
  814.   ;; graph view.  Loop to find the node with the smallest manhattan distance 
  815.   ;; from the mouse, and perform the appropriate operation on that node.
  816.   (when graph-view
  817.     (do ((gn+p-ptr (graph-view-members (sm:gets 'graph-view graph-view)) 
  818.                    (cdr gn+p-ptr))
  819.          (nearest-node nil)
  820.          (smallest-distance *screen-width*) ; a big number to start with
  821.          (distance 0))
  822.         ;; Exit: ensure the click was close enough.
  823.         ((null gn+p-ptr)
  824.          (if (< smallest-distance *graph-window-double-click-spacing*)
  825.            ;; Close enough to identify a nearest-node.  Primary action depends on
  826.            ;; what is already selected.  If user is holding mouse down (wait a bit 
  827.            ;; to see), will move the node.  When moving, the primary action is done 
  828.            ;; only if necessary to select the node to be moved.
  829.            (cond ((null selected-node)
  830.                   ;; First click on this node and no other node selected: highlight.
  831.                   (setq selected-node nearest-node)
  832.                   (invert-node selected-node)
  833.                   (if (progn (sleep *graph-window-mouse-down-delay*) (mouse-down-p))
  834.                     (move-node selected-node)))
  835.                  ((eq selected-node nearest-node)
  836.                   ;; Second click on selected: move OR do mouse method, depending on 
  837.                   ;; whether mouse held.  (Both would be too confusing).
  838.                   (if (progn (sleep *graph-window-mouse-down-delay*) (mouse-down-p))
  839.                     (move-node selected-node)
  840.                     (run-mouse-method (ccl:front-window) ; ccl:self didn't work!
  841.                                       graph-view selected-node)))
  842.                  (T 
  843.                   ;; Node clicked differs from node highlighted: change selected.
  844.                   (invert-node selected-node)
  845.                   (invert-node nearest-node)
  846.                   (setq selected-node nearest-node)
  847.                   (if (progn (sleep *graph-window-mouse-down-delay*) (mouse-down-p))
  848.                     (move-node selected-node))))
  849.            ;; Click is in whitespace: turn off any selected node, or redraw contents
  850.            ;; if this is the second of a double click (first click deselected node).
  851.            (if selected-node
  852.              (progn (invert-node selected-node) (setq selected-node nil))
  853.              (if (double-click-p) (view-draw-contents)))))
  854.       (declare (list gn+p-ptr) (fixnum smallest-distance distance) 
  855.                (optimize (safety 1) (space 2) (speed 3)))
  856.       ;; Find the manhattan distance from the mouse click to the center of this node.
  857.       (setf distance
  858.             (manhattan-distance
  859.              mouse-position
  860.              (add-points (graph-node-center (sm:gets 'graph-node (caar gn+p-ptr)))
  861.                          (node-placement-position (cdar gn+p-ptr)))))
  862.       ;; Record it as the closest so far if closer than the previous closest node.
  863.       (when (< distance smallest-distance)
  864.         (setf nearest-node (caar gn+p-ptr))
  865.         (setf smallest-distance distance)))))
  866.  
  867. (defobfun (INVERT-NODE *graph-window*) (node)
  868.   (declare (object-variable graph-view))
  869.   ;; Assumes it is already drawn; inverts the thing.
  870.   (let* ((node+placement 
  871.           (assoc node (graph-view-members (sm:gets 'graph-view graph-view))))
  872.          (node-placement-position (node-placement-position (cdr node+placement)))
  873.          (box-size (graph-node-box-size (sm:gets 'graph-node (car node+placement)))))
  874.     (declare (cons node+placement) (list node-font) 
  875.              (fixnum node-placement-position box-size))
  876.     ;; Invert everything in the box outline region.
  877.     (case (graph-node-box-style (sm:gets 'graph-node (car node+placement)))
  878.       ((:none :rect :frame :none-frame)
  879.        (invert-rect node-placement-position 
  880.                     (add-points node-placement-position box-size)))
  881.       ((:round-rect :round-frame)
  882.        (invert-round-rect 
  883.         (point-v box-size)
  884.         (point-v box-size)
  885.         node-placement-position
  886.         (add-points node-placement-position box-size)))
  887.       ((:oval)
  888.        (invert-oval node-placement-position
  889.                     (add-points node-placement-position box-size))))))
  890.  
  891. (defobfun (MOVE-NODE *graph-window*) (node)
  892.   (declare (object-variable graph-view selected-node))
  893.   ;; Tracks the mouse and repositions <node> when and where the mouse is released.
  894.   ;; Placement is such that the mouse points to the CENTER of the box position.
  895.   (let ((node+placement 
  896.          (assoc node
  897.                 (graph-view-members (sm:gets 'graph-view graph-view))))
  898.         (time (get-internal-run-time))
  899.         (center-offset 
  900.          (graph-node-center (sm:gets 'graph-node selected-node))))
  901.     (declare (cons node+placement) (fixnum time center-offset) 
  902.              (optimize (safety 1) (space 2) (speed 3)))
  903.     ;; Start with this to improve apparent response time. (We already had
  904.     ;; a 0.5 sec. delay in the calling function.)
  905.     (draw-graph-node-outline node center-offset)
  906.     (loop
  907.       ;; Draw outline occasionally.  This lets user see where it will go.
  908.       ;; If drawn too often, the screen will get cluttered since we are 
  909.       ;; not erasing previous outlines.
  910.       (when (> (- (get-internal-run-time) time)
  911.                *outline-time-interval*)
  912.         (draw-graph-node-outline node center-offset)
  913.         (setq time (get-internal-run-time)))
  914.       ;; Reposition node, redraw window, and exit when mouse released.
  915.       (unless (mouse-down-p)
  916.         (setf (node-placement-position (cdr node+placement))
  917.               (subtract-points (window-mouse-position) center-offset))
  918.         (return (view-draw-contents))))))
  919.  
  920. (defobfun (DRAW-GRAPH-NODE-OUTLINE *graph-window*) (node center-offset)
  921.   (let* ((node-struct (sm:gets 'graph-node node))
  922.          (box-style (graph-node-box-style node-struct))
  923.          (box-size (graph-node-box-size node-struct))
  924.          (position (subtract-points (window-mouse-position) center-offset)))
  925.     (declare (type graph-node node-struct) (keyword box-style)
  926.              (fixnum box-size position) (optimize (safety 1) (space 2) (speed 3)))
  927.     ;; Draw box outline.
  928.     (set-pen-pattern *light-gray-pattern*)
  929.     (case box-style
  930.       ((:none :rect :none-frame :frame)
  931.        (frame-rect
  932.         position
  933.         (add-points position box-size)))
  934.       ((:round-rect :round-frame)
  935.        (frame-round-rect 
  936.         (point-v box-size)
  937.         (point-v box-size)
  938.         position
  939.         (add-points position box-size)))
  940.       ((:oval)
  941.        (frame-oval
  942.         position
  943.         (add-points position box-size))))
  944.     (pen-normal)))
  945.  
  946. (defobfun (ccl::WINDOW-KEY-EVENT-HANDLER *graph-window*) (char)
  947.   (declare (object-variable graph-view selected-node))
  948.   ;; Interprets arrow keys to move around in the graph. 
  949.   (when graph-view
  950.     (case char
  951.       ((#\ #\) ; down and right arrows: make selected node the root.
  952.        (let ((method (assoc "make this node the root"
  953.                             (graph-view-mouse-methods (sm:gets 'graph-view graph-view))
  954.                             :test #'string-equal)))
  955.          (if (and selected-node method)
  956.            (funcall (cdr method) (self) graph-view selected-node)
  957.            (ccl:ed-beep))))
  958.       ((#\ #\) ; left and up arrows: return to previous view.
  959.        (let ((method (assoc "backup once to parent view"
  960.                             (graph-view-mouse-methods (sm:gets 'graph-view graph-view))
  961.                             :test #'string-equal)))
  962.          (if method 
  963.            (funcall (cdr method) (self) graph-view selected-node)
  964.            (ccl:ed-beep)))))))
  965.  
  966. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  967. ;;; 
  968. ;;;                        GRAPH LAYOUT MACROS
  969. ;;;
  970. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  971.  
  972. (eval-when (compile eval)
  973.  
  974.   (defmacro LAYER-SPACE-FOR-STYLE (layout-style border-width)
  975.     ;; Computes how much space is available in the direction the layers are drawn.
  976.     ;; Vertical tree is centered in layers and fixed v-size, so no border off.
  977.     `(ecase ,layout-style
  978.             ((:vertical-tree :vertical-tree*)
  979.              (point-v (window-size)))
  980.             ((:horizontal-tree :horizontal-tree*)
  981.              (- (point-h (window-size)) (* 2 ,border-width)))
  982.             ((:radial :radial*)
  983.              (truncate (/ (float (- (min (point-v (window-size))
  984.                                          (point-h (window-size)))
  985.                                     (* 2 ,border-width))) 
  986.                           2.0)))))
  987.  
  988.   (defmacro SIBLING-SPACE-FOR-STYLE (layout-style border-width)
  989.     ;; Computes how much space is available in the direction siblings are drawn.
  990.     `(ecase ,layout-style
  991.             ((:vertical-tree :vertical-tree*)
  992.              (- (point-h (window-size)) (* 2 ,border-width)))
  993.             ((:horizontal-tree :horizontal-tree*)
  994.              (- (point-v (window-size)) (* 2 ,border-width)))
  995.             ;; White lie: give them radians to work with; will convert to
  996.             ;; cartesian later.  (Without angular measure, space available to
  997.             ;; siblings would vary with depth).  There are 6.28 radians in a 
  998.             ;; circle: using 62800 to faciliate fast but accurate integer math.
  999.             ((:radial  :radial*) 62800)))
  1000.  
  1001.   (defmacro EQUALLY-ALLOCATED-SPACE (space-available number-of-contendors)
  1002.     ;; Determine how much space each of n contendors gets.
  1003.     `(let ((denominator ,number-of-contendors)
  1004.            (numerator   ,space-available))
  1005.        (if (= denominator 0) 
  1006.          numerator 
  1007.          ;; Rounding up does risk overflow, but only in graphs with an absurd
  1008.          ;; number of elements.  I tried all kinds of things here; this is best.
  1009.          (ceiling (/ (float numerator)
  1010.                      (float denominator))))))
  1011.  
  1012.   ;;; Find start point of range given which range and the number of points per range.
  1013.   (defmacro RANGE-START (range points) `(* ,range ,points))
  1014.   
  1015.   ;;; Find center point of range given which range and the number of points per range.
  1016.   (defmacro RANGE-CENTER (range points)
  1017.     `(truncate (* (+ 0.5 (float ,range)) (float ,points))))
  1018.  
  1019.   ;;; Find end point of range given which range and the number of points per range.
  1020.   (defmacro RANGE-END (range points) `(* (+ 1 ,range) ,points))
  1021.   
  1022.   ;;; Center a box at a given horizontal coordinate, taking box width into account.
  1023.   (defmacro CENTER-BOX-AT-H (box-size h-place)
  1024.     `(- ,h-place
  1025.         (truncate (/ (float (point-h ,box-size)) 2.0))))
  1026.   
  1027.   ;;; Center a box at a given vertical coordinate, taking box height into account.
  1028.   (defmacro CENTER-BOX-AT-V (box-size v-place) 
  1029.     `(- ,v-place
  1030.         (truncate (/ (float (point-v ,box-size)) 2.0))))
  1031.  
  1032.   )
  1033.  
  1034. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1035. ;;;
  1036. ;;;                     GRAPH LAYOUT AND DRAWING METHODS
  1037. ;;;
  1038. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1039.  
  1040. ;;; Apologies for the oversized function.  Just couldn't break it up nice.
  1041.  
  1042. (defobfun (LAYOUT-GRAPH-VIEW *graph-window*) ()
  1043.   "layout-graph-view                                   [Graph Window Function]
  1044.   Computes the layout for a graph-window's graph view, without displaying it.
  1045.   In this simple version, we assume a fixed finite window size, and try to
  1046.   fit everything in.  (If it doesn't fit, the user may create sub-views and
  1047.   move between them.)  The layers are each given an equal amount of space
  1048.   in one dimension (which depending on whether it is a horizontal, vertical,
  1049.   or radial style), as is each node within each layer in the other dimension.
  1050.   In the layer direction, nodes are placed at the start of the range allocated
  1051.   to that layer.  In the within-layer, node direction, each node is centered
  1052.   in the range allocated to it."
  1053.   (declare (object-variable graph-view window-title))
  1054.   
  1055.   (when graph-view ; NIL represents the empty graph, so nothing is done in that case.
  1056.     (assert (sm:gets 'graph-view graph-view) (graph-view)
  1057.             "[GRAPHER:LAYOUT-GRAPH-VIEW] Graph Window ~S has bad graph view ~S."
  1058.             window-title graph-view)
  1059.     
  1060.     (let* ((graph-view-struct   (sm:gets 'graph-view graph-view))
  1061.            (layout-style        (graph-view-style graph-view-struct))
  1062.            (view-members        (compute-graph-view-members 
  1063.                                  graph-view 
  1064.                                  layout-style
  1065.                                  (graph-view-ordering graph-view-struct)))
  1066.            (border-width        (graph-view-border-width graph-view-struct))
  1067.            (total-sibling-space (sibling-space-for-style layout-style border-width))
  1068.            (layer-spacing       (equally-allocated-space
  1069.                                  (layer-space-for-style layout-style border-width)
  1070.                                  (graph-view-levels graph-view-struct))))
  1071.       (declare (type graph-view graph-view-struct)
  1072.                (keyword layout-style) (list vertical-format-p view-members)
  1073.                (fixnum border-width total-sibling-space layer-spacing)
  1074.                (optimize (safety 1) (space 2) (speed 3)))
  1075.       
  1076.       ;; Ensure that graph-independent node parameters have been computed.
  1077.       (dolist (node+placement view-members)
  1078.         (declare (cons node+placement))
  1079.         (let* ((node-struct (sm:gets 'graph-node (car node+placement)))
  1080.                (node-font (graph-view-node-font graph-view-struct))
  1081.                (box-style (graph-node-box-style node-struct))
  1082.                ;; A bit messy, but empirically the padding depends on font and style.
  1083.                (box-height (multiple-value-bind
  1084.                              (a d) (font-info node-font)
  1085.                              (if (member box-style *framed-styles*)
  1086.                                (* (length (graph-node-label node-struct)) 
  1087.                                   (+ a d (if (< (second node-font) 
  1088.                                                 *small-font-threshold*)
  1089.                                            *small-font-box-height-padding*
  1090.                                            *large-font-box-height-padding*)))
  1091.                                (+ a d (ecase box-style
  1092.                                         ((:none :rect :round-rect) 
  1093.                                          (if (< (second node-font) 
  1094.                                                 *small-font-threshold*) 
  1095.                                            *small-font-box-height-padding*
  1096.                                            *large-font-box-height-padding*))
  1097.                                         ((:oval)
  1098.                                          (if (< (second node-font)
  1099.                                                 *small-font-threshold*)
  1100.                                            *small-font-oval-box-height-padding* 
  1101.                                            *large-font-oval-box-height-padding*)))))))
  1102.                (box-half-height (truncate (/ (float box-height) 2.0)))
  1103.                (box-width (+ (if (member box-style *framed-styles*)
  1104.                                (apply #'max 
  1105.                                       (mapcar #'(lambda (s) (declare (string s))
  1106.                                                  (string-width s node-font))
  1107.                                               (graph-node-label node-struct)))
  1108.                                (string-width (graph-node-label node-struct) node-font))
  1109.                              (ecase box-style ; padding required for each style
  1110.                                ((:none :rect :none-frame :frame) *rect-box-width-padding*)
  1111.                                ((:round-rect) *round-rect-box-width-padding*)
  1112.                                ((:round-frame) *round-frame-box-width-padding*)
  1113.                                ((:oval) *oval-box-width-padding*))))
  1114.                (box-half-width (truncate (/ (float box-width) 2.0))))
  1115.           (declare (type graph-node node-struct) (list node-font) (keyword box-style) 
  1116.                    (fixnum box-height box-half-height box-width box-half-width))
  1117.           (setf (graph-node-box-size node-struct)
  1118.                 (make-point box-width box-height))
  1119.           (setf (graph-node-top-center node-struct)
  1120.                 (make-point box-half-width 0))
  1121.           (setf (graph-node-bottom-center node-struct)
  1122.                 (make-point box-half-width box-height))
  1123.           (setf (graph-node-left-center node-struct)
  1124.                 (make-point 0 box-half-height))
  1125.           (setf (graph-node-right-center node-struct)
  1126.                 (make-point box-width box-half-height))
  1127.           (setf (graph-node-center node-struct)
  1128.                 (make-point box-half-width box-half-height))))
  1129.       
  1130.       ;; Iterate over levels (depth 0 = level 1) to layout nodes in each level.
  1131.       (dotimes (depth (graph-view-levels graph-view-struct))
  1132.         (declare (fixnum depth))
  1133.         (let* ((level-nodes+placements
  1134.                 (ordered-nodes+placements-at-level
  1135.                  view-members (1+ depth) (graph-view-ordering graph-view-struct)))
  1136.                (sibling-spacing
  1137.                 (equally-allocated-space total-sibling-space 
  1138.                                          (length level-nodes+placements))))
  1139.           (declare (list level-nodes+placements) (fixnum sibling-spacing))
  1140.           
  1141.           ;; Iterate over nodes in this level to compute the placements.
  1142.           (do* ((n+pptr level-nodes+placements (rest n+pptr))
  1143.                 (node-number 0 (1+ node-number)))
  1144.                ((null n+pptr))
  1145.             (declare (list n+pptr) (fixnum node-number))
  1146.             (let* ((node+placement (car n+pptr))
  1147.                    (box-size (graph-node-box-size 
  1148.                               (sm:gets 'graph-node (car node+placement)))))
  1149.               (declare (cons node+placement) (fixnum box-size))
  1150.               (case layout-style
  1151.                 ;; In all layouts, the box is placed at the center of its within-level
  1152.                 ;; allocated space, but at the beginning of its level's range.  Trees
  1153.                 ;; differ on which is horizontal and which vertical.
  1154.                 ((:vertical-tree :vertical-tree*)
  1155.                  (setf (node-placement-position (cdr node+placement))
  1156.                        (make-point
  1157.                         (+ border-width 
  1158.                            (center-box-at-h box-size 
  1159.                                             (range-center node-number sibling-spacing)))
  1160.                         (center-box-at-v box-size 
  1161.                                          (range-center depth layer-spacing)))))
  1162.                 ;; Not centering layers, since would be ragged, so shift two borders
  1163.                 ;; worth to make up for it.
  1164.                 ((:horizontal-tree :horizontal-tree*)
  1165.                  (setf (node-placement-position (cdr node+placement))
  1166.                        (make-point 
  1167.                         (+ (* 2 border-width) (range-start depth layer-spacing))
  1168.                         (+ border-width 
  1169.                            (center-box-at-v box-size 
  1170.                                             (range-center node-number sibling-spacing))))))
  1171.                 ;; Parameters for :radial similar to :vertical-tree, but placement and
  1172.                 ;; centering is interspersed with coordinate conversion.  First find its
  1173.                 ;; place, which is the center of its allocated radians (p) and radius (r)
  1174.                 ;; ranges.  Then convert.  THEN center the actual box over its place, so 
  1175.                 ;; adjustment is in the relevant dimensions.
  1176.                 ((:radial :radial*)
  1177.                  (let* ((radial-p (/ (float (range-center node-number sibling-spacing))
  1178.                                      10000.0))
  1179.                         (radial-r (if (= depth 0) 0.0 (float (range-end depth layer-spacing))))
  1180.                         (cartesian-h (+ (round (* radial-r (cos radial-p)))
  1181.                                         (round (/ (float (point-h (window-size))) 2.0))))
  1182.                         (cartesian-v (+ (round (* radial-r (sin radial-p)))
  1183.                                         (round (/ (float (point-v (window-size))) 2.0)))))
  1184.                    (declare (float radial-p radial-r) (fixnum cartesian-h cartesian-v))
  1185.                    ;; Need this info later to determine attachment points. Prefer top
  1186.                    ;; or bottom attachements = upper or lower classifications.
  1187.                    (setf (node-placement-quadrant (cdr node+placement))
  1188.                          (cond ((< radial-p (utils:radians 30.0))  :right)
  1189.                                ((< radial-p (utils:radians 150.0)) :lower)
  1190.                                ((< radial-p (utils:radians 210.0)) :left)
  1191.                                ((< radial-p (utils:radians 330.0)) :upper)
  1192.                                (T :right)))
  1193.                    (setf (node-placement-position (cdr node+placement))
  1194.                          (make-point (center-box-at-h box-size cartesian-h)
  1195.                                      (center-box-at-v box-size cartesian-v)))))))))))))
  1196.  
  1197. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1198. ;;; DRAWING
  1199. ;;; I used to use pictures, but dumped it due to bugs.  I used to get:
  1200. ;;; Picture for window: #<Object #167, MacGrapher, a *WINDOW*> is not started
  1201. ;;; even though I called (start-picture) unconditionally.  Now, the only 
  1202. ;;; computation we can save is not calling the layout-graph-view twice.
  1203.  
  1204. (defobfun (VIEW-DRAW-CONTENTS *graph-window*) ()
  1205.   "view-draw-contents                                 [Graph Window Function]
  1206.   Draws a graph-window's graph view.  It must have a graph view, and you
  1207.   must invoke layout-graph-view at least once before drawing: see that 
  1208.   method's documentation."
  1209.   (declare (object-variable graph-view selected-node window-title))
  1210.  
  1211.   ;; Nil is now the representation of the empty graph view.  We clear the window
  1212.   ;; first no matter what happens, so if graph-view is nil no drawing need be done.
  1213.   (erase-region (clip-region))
  1214.   (when graph-view
  1215.     (assert (sm:gets 'graph-view graph-view) (graph-view)
  1216.             "Graph Window ~S has bad graph view ~S."
  1217.             window-title graph-view)
  1218.     
  1219.     (let* ((graph-view-struct (sm:gets 'graph-view graph-view))
  1220.            (layout-style  (graph-view-style graph-view-struct))
  1221.            (view-members (graph-view-members graph-view-struct)))
  1222.       (declare (type graph-view graph-view-struct)
  1223.                (keyword layout-style) (list view-members) 
  1224.                (optimize (safety 1) (space 2) (speed 3)))
  1225.       
  1226.       ;; Draw lines to all children for each node+placement in the view-members.
  1227.       ;; Draw lines first, so when boxes drawn they are in front of lines.
  1228.       (dolist (node+placement view-members)
  1229.         (declare (cons node+placement))
  1230.         (dolist (child (graph-node-children (sm:gets 'graph-node (car node+placement))))
  1231.           (declare (symbol child))
  1232.           ;; Filter out children that were not included in the view.
  1233.           (let ((child-node+placement (assoc child view-members)))
  1234.             (declare (cons child-node+placement))
  1235.             (if child-node+placement
  1236.               (draw-parent-to-child-link
  1237.                node+placement child-node+placement layout-style)))))
  1238.       
  1239.       ;; Then draw the nodes themselves, and invert the selected node.
  1240.       (set-window-font (graph-view-node-font graph-view-struct))
  1241.       (dolist (node+placement view-members)
  1242.         (declare (cons node+placement))
  1243.         (draw-graph-node node+placement (graph-view-node-font graph-view-struct)))
  1244.       (set-window-font (graph-view-text-font graph-view-struct))
  1245.       (if selected-node (invert-node selected-node))
  1246.  
  1247.       ;; Put the grow icon back in, and Return the view drawn.
  1248.       (window-draw-grow-icon)
  1249.       graph-view)))
  1250.  
  1251. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1252. ;;;
  1253. ;;;                        GRAPH VIEW COMPUTATIONS
  1254. ;;;
  1255. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1256.  
  1257. ;;; Given a graph object, compute the members of the graph.
  1258. ;;; In the process, check for cycles.
  1259. ;;; Terminology: the root is at "depth" 0 but "level" 1. 
  1260.  
  1261. (defun COMPUTE-GRAPH-VIEW-MEMBERS (graph-view layout-style ordering)
  1262.   (declare (symbol graph-view layout-style ordering))
  1263.   (let* ((*graph-view-struct* (sm:gets 'graph-view graph-view))
  1264.          (*active-nodes*      nil)
  1265.          (*depth-bound*       (graph-view-depth-bound *graph-view-struct*)))
  1266.     (declare (special *graph-view-struct* *active-nodes* *depth-bound*)
  1267.              (type graph-view *graph-view-struct*)
  1268.              (list *active-nodes*) (integer *depth-bound*) 
  1269.              (optimize (safety 1) (space 2) (speed 3)))
  1270.     
  1271.     ;; Two helpers for ordering children, then a recursive function
  1272.     ;; that does the work ...
  1273.  
  1274.     (defun REORDER-TO-MINIMIZE-CROSSINGS (children)
  1275.       ;; Prefers to do first children which themselves have children already
  1276.       ;; in the graph, and resolves between multiple such children by doing 
  1277.       ;; the one with the earliest (first visited) grandchild first. This 
  1278.       ;; reduces the number of children that have to link across other 
  1279.       ;; children's links to get to their children.
  1280.       (declare (list children))
  1281.       (mapcar #'car
  1282.               (stable-sort (mapcar #'(lambda (node)
  1283.                                        (declare (symbol node))
  1284.                                        (cons node (earliest-child-placement
  1285.                                                    (graph-node-children 
  1286.                                                     (sm:gets 'graph-node node)))))
  1287.                                    children)
  1288.                            #'(lambda (f1 f2)
  1289.                                (declare (cons f1 f2))
  1290.                                (<= (cdr f1) (cdr f2))))))
  1291.  
  1292.     (defun EARLIEST-CHILD-PLACEMENT (children)
  1293.       (declare (list children) (special *graph-view-struct*))
  1294.       (let ((smallest most-positive-fixnum))
  1295.         (declare (fixnum smallest))
  1296.         (dolist (child children)
  1297.           (declare (symbol child))
  1298.           ;; This depends on order being preserved in the members list.
  1299.           (let ((child-score (or (position child
  1300.                                            (graph-view-members *graph-view-struct*)
  1301.                                            :key #'car)
  1302.                                  most-positive-fixnum)))
  1303.             (declare (fixnum child-score))
  1304.             (if (<= child-score smallest) (setf smallest child-score))))
  1305.         smallest))
  1306.  
  1307.  
  1308.     (defun VISIT-NODE-AND-RECURSE (node current-depth)
  1309.       ;; Adds the node or updates its depth; and then recurses on children.
  1310.       (declare (special *graph-view-struct* *active-nodes* *depth-bound*)
  1311.                (symbol node) (integer current-depth)
  1312.                (optimize (safety 1) (space 2) (speed 3)))
  1313.       ;; Don't do it if we've found our way back via a cycle, or have gone too deep. 
  1314.       (unless (or (> current-depth *depth-bound*)
  1315.                   (member node *active-nodes*))
  1316.         (let ((node-placement
  1317.                (utils:image node (graph-view-members *graph-view-struct*))))
  1318.           (declare (vector node-placement))
  1319.           (if node-placement
  1320.             ;; If the node has been visited, update its level to the deeper one.
  1321.             (setf (node-placement-level node-placement)
  1322.                   (max (1+ current-depth) (node-placement-level node-placement)))
  1323.             ;; Otherwise add a new view-member record for this newly visited node.
  1324.             ;; (I had a push here, but it was reversing the graphed order of children.)
  1325.             ;; NOTE I rely on this ordering in earliest-child-placement, above!
  1326.             (setf (graph-view-members *graph-view-struct*)
  1327.                   (nconc (graph-view-members *graph-view-struct*)
  1328.                          (list (cons node
  1329.                                      (make-node-placement :level (1+ current-depth))))))))
  1330.         ;; Update max depth of graph; Recurse to add children if not too deep.
  1331.         (setf (graph-view-levels *graph-view-struct*)
  1332.               (max (graph-view-levels *graph-view-struct*) (1+ current-depth)))
  1333.         (unless (> (1+ current-depth) *depth-bound*)
  1334.           (push node *active-nodes*)
  1335.           (let ((children (graph-node-children (sm:gets 'graph-node node))))
  1336.             (declare (list children))
  1337.             (if (member ordering
  1338.                         '(:reduce-crossings :reverse-reduce-crossings))
  1339.               (loop
  1340.                 (when (null children) (return))
  1341.                 (setf children (reorder-to-minimize-crossings children))
  1342.                 (visit-node-and-recurse (pop children) (1+ current-depth)))
  1343.               (dolist (child children)
  1344.                 (declare (symbol child))
  1345.                 (visit-node-and-recurse child (1+ current-depth)))))
  1346.           (pop *active-nodes*))))
  1347.  
  1348.     ;; Prepare for recomputation of members list.
  1349.     (setf (graph-view-members *graph-view-struct*) nil)
  1350.  
  1351.     ;; The * styles collect childless roots and put them in the first
  1352.     ;; level, starting roots with children at level 2 (where depth 1
  1353.     ;; normally would be).  Determine if this is needed; call the helper
  1354.     ;; function on each of the roots with the appropriate starting depth.
  1355.     (if (and (member layout-style *starred-styles*)
  1356.              (some #'(lambda (root)
  1357.                        (null (graph-node-children (sm:gets 'graph-node root))))
  1358.                    (graph-view-roots *graph-view-struct*)))
  1359.       (dolist (root (graph-view-roots *graph-view-struct*))
  1360.         (declare (symbol root))
  1361.         (if (null (graph-node-children (sm:gets 'graph-node root)))
  1362.           (visit-node-and-recurse root 0)
  1363.           (visit-node-and-recurse root 1)))
  1364.       (dolist (root (graph-view-roots *graph-view-struct*))
  1365.         (declare (symbol root))
  1366.         (visit-node-and-recurse root 0)))
  1367.  
  1368.     ;; It is possible for all roots initially placed in column 1 to be
  1369.     ;; reached by alternate paths and pushed down.  Check for this
  1370.     ;; condition and shift everyone up if needed.
  1371.     (when (notany #'(lambda (node+placement)
  1372.                       (declare (cons node+placement))
  1373.                       (= 1 (node-placement-level (cdr node+placement))))
  1374.                   (graph-view-members *graph-view-struct*))
  1375.       (dolist (node+placement (graph-view-members *graph-view-struct*))
  1376.         (decf (node-placement-level (cdr node+placement))))
  1377.       (decf (graph-view-levels *graph-view-struct*)))
  1378.  
  1379.     ;; Return the computed members, stored in the structure as well.
  1380.     (graph-view-members *graph-view-struct*))
  1381.   )
  1382.  
  1383. ;;; This extracts node+placement records at a level, and orders it in 
  1384. ;;; ways which affect the layout according to the style.
  1385.  
  1386. (defun ORDERED-NODES+PLACEMENTS-AT-LEVEL (view-members level ordering)
  1387.   (declare (list view-members) (integer level) (keyword :ordering))
  1388.   (ecase ordering
  1389.     ((:as-found :reduce-crossings)
  1390.      (nodes+placements-at-level view-members level))
  1391.     ((:reverse-as-found :reverse-reduce-crossings)
  1392.      (reverse (nodes+placements-at-level view-members level)))))
  1393.  
  1394. (defun NODES+PLACEMENTS-AT-LEVEL (view-members level)
  1395.   (declare (list view-members) (integer level) 
  1396.            (optimize (safety 1) (space 2) (speed 3)))
  1397.   (remove-if-not
  1398.    #'(lambda (node+placement)
  1399.        (declare (cons node+placement))
  1400.        (= level (node-placement-level (cdr node+placement))))
  1401.    view-members))
  1402.  
  1403. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1404. ;;; Drawing
  1405.  
  1406. (defun DRAW-PARENT-TO-CHILD-LINK (pnode+placement cnode+placement layout-style)
  1407.   ;; 
  1408.   ;; Sensitive to what the layout style is, whether the child is in a lower
  1409.   ;; or higher layer, and where they are positioned relative to each other.
  1410.   ;; Based on all this, tries to attach the links in nice looking locations
  1411.   ;; (i.e. the midpoint of the sides of the nodes facing each other, except
  1412.   ;; when the link is a backlink, which is visually indicated by not using
  1413.   ;; the normal attachment points). Big, ugly, brute-force approach.
  1414.   ;;
  1415.   (declare (cons pnode+placement cnode+placement) (keyword layout-style)
  1416.            (optimize (safety 0) (space 2) (speed 3)))
  1417.  
  1418.   (let ((parent-struct (sm:gets 'graph-node (car pnode+placement)))
  1419.         (child-struct  (sm:gets 'graph-node (car cnode+placement)))
  1420.         (child-quadrant (node-placement-quadrant (cdr cnode+placement)))
  1421.  
  1422.          ;; Want to know relative position in cartesian coordinates regardless
  1423.          ;; of layout, so we know what sides are facing each other.
  1424.         (parent-v-<-child-v?
  1425.          (> (- (point-v (node-placement-position (cdr cnode+placement)))
  1426.                (point-v (node-placement-position (cdr pnode+placement))))
  1427.             *relative-v-position-threshold*))
  1428.         (parent-h-<-child-h?
  1429.          (> (- (point-h (node-placement-position (cdr cnode+placement)))
  1430.                (point-h (node-placement-position (cdr pnode+placement))))
  1431.             *relative-h-position-threshold*))
  1432.         (child-v-<-parent-v?
  1433.          (> (- (point-v (node-placement-position (cdr pnode+placement)))
  1434.                (point-v (node-placement-position (cdr cnode+placement))))
  1435.             *relative-v-position-threshold*))
  1436.         (child-h-<-parent-h?
  1437.          (> (- (point-h (node-placement-position (cdr pnode+placement)))
  1438.                (point-h (node-placement-position (cdr cnode+placement))))
  1439.             *relative-h-position-threshold*))
  1440.         
  1441.         ;; These will be computed
  1442.         (parent-attachment 0)
  1443.         (child-attachment 0))
  1444.  
  1445.     (declare (type graph-node parent-struct child-struct)
  1446.              (fixnum parent-attachment child-attachment))
  1447.  
  1448.     ;; Three cases for horizontal and vertical relative positioning: less,
  1449.     ;; equal (within an error tolerance), or greater.  Gives 9 cases.  Then
  1450.     ;; subdivide further by layout style.
  1451.     ;;
  1452.     (cond
  1453.  
  1454.      (parent-v-<-child-v?
  1455.       (cond
  1456.  
  1457.        (parent-h-<-child-h? 
  1458.         ;;
  1459.         ;; Parent above and to left of child.
  1460.         ;;
  1461.         (ecase layout-style
  1462.           ((:vertical-tree :vertical-tree*)
  1463.            (setf parent-attachment
  1464.                  (add-points (node-placement-position (cdr pnode+placement))
  1465.                              (graph-node-bottom-center parent-struct)))
  1466.            (setf child-attachment
  1467.                  (add-points (node-placement-position (cdr cnode+placement))
  1468.                              (graph-node-top-center child-struct))))
  1469.           ((:horizontal-tree :horizontal-tree*)
  1470.            (setf parent-attachment
  1471.                  (add-points (node-placement-position (cdr pnode+placement))
  1472.                              (graph-node-right-center parent-struct)))
  1473.            (setf child-attachment
  1474.                  (add-points (node-placement-position (cdr cnode+placement))
  1475.                              (graph-node-left-center child-struct))))
  1476.           ((:radial :radial*)
  1477.            (ecase child-quadrant
  1478.              ((:upper)
  1479.               (setf parent-attachment
  1480.                     (add-points (node-placement-position (cdr pnode+placement))
  1481.                                 (graph-node-right-center parent-struct)))
  1482.               (setf child-attachment
  1483.                     (add-points (node-placement-position (cdr cnode+placement))
  1484.                                 (graph-node-left-center child-struct))))
  1485.              ((:lower :left :right)
  1486.               (setf parent-attachment
  1487.                     (add-points (node-placement-position (cdr pnode+placement))
  1488.                                 (graph-node-bottom-center parent-struct)))
  1489.               (setf child-attachment
  1490.                     (add-points (node-placement-position (cdr cnode+placement))
  1491.                                 (graph-node-top-center child-struct)))))))
  1492.         )
  1493.  
  1494.        (child-h-<-parent-h? 
  1495.         ;;
  1496.         ;; Parent above and to right of child.
  1497.         ;;
  1498.         (ecase layout-style
  1499.           ((:vertical-tree :vertical-tree* :horizontal-tree :horizontal-tree*)
  1500.            ;; It's a backlink in the horizontal styles.
  1501.            (setf parent-attachment
  1502.                  (add-points (node-placement-position (cdr pnode+placement))
  1503.                              (graph-node-bottom-center parent-struct)))
  1504.            (setf child-attachment
  1505.                  (add-points (node-placement-position (cdr cnode+placement))
  1506.                              (graph-node-top-center child-struct))))
  1507.           ((:radial :radial*)
  1508.            (ecase child-quadrant
  1509.              ((:upper :left)
  1510.               (setf parent-attachment
  1511.                     (add-points (node-placement-position (cdr pnode+placement))
  1512.                                 (graph-node-left-center parent-struct)))
  1513.               (setf child-attachment
  1514.                     (add-points (node-placement-position (cdr cnode+placement))
  1515.                                 (graph-node-right-center child-struct))))
  1516.              ((:lower :right)
  1517.               (setf parent-attachment
  1518.                     (add-points (node-placement-position (cdr pnode+placement))
  1519.                                 (graph-node-bottom-center parent-struct)))
  1520.               (setf child-attachment
  1521.                     (add-points (node-placement-position (cdr cnode+placement))
  1522.                                 (graph-node-top-center child-struct)))))))
  1523.         )
  1524.  
  1525.        (T 
  1526.         ;;
  1527.         ;; Parent centered over child.
  1528.         ;;
  1529.         (setf parent-attachment
  1530.               (add-points (node-placement-position (cdr pnode+placement))
  1531.                           (graph-node-bottom-center parent-struct)))
  1532.         (setf child-attachment
  1533.               (add-points (node-placement-position (cdr cnode+placement))
  1534.                           (graph-node-top-center child-struct)))
  1535.         )))
  1536.  
  1537.      (child-v-<-parent-v?
  1538.       (cond 
  1539.  
  1540.        (parent-h-<-child-h? 
  1541.         ;;
  1542.         ;; Parent below and to left of child.
  1543.         ;;
  1544.         (ecase layout-style
  1545.           ((:horizontal-tree :horizontal-tree* :vertical-tree :vertical-tree*)
  1546.            ;; Backlink for vertical styles.
  1547.            (setf parent-attachment
  1548.                  (add-points (node-placement-position (cdr pnode+placement))
  1549.                              (graph-node-right-center parent-struct)))
  1550.            (setf child-attachment
  1551.                  (add-points (node-placement-position (cdr cnode+placement))
  1552.                              (graph-node-left-center child-struct))))
  1553.           ((:radial :radial*)
  1554.            (ecase child-quadrant
  1555.              ((:upper :left)
  1556.               (setf parent-attachment
  1557.                     (add-points (node-placement-position (cdr pnode+placement))
  1558.                                 (graph-node-top-center parent-struct)))
  1559.               (setf child-attachment
  1560.                     (add-points (node-placement-position (cdr cnode+placement))
  1561.                                 (graph-node-bottom-center child-struct))))
  1562.              ((:lower :right)
  1563.               (setf parent-attachment
  1564.                     (add-points (node-placement-position (cdr pnode+placement))
  1565.                                 (graph-node-right-center parent-struct)))
  1566.               (setf child-attachment
  1567.                     (add-points (node-placement-position (cdr cnode+placement))
  1568.                                 (graph-node-left-center child-struct)))))))
  1569.         )
  1570.  
  1571.        (child-h-<-parent-h?
  1572.         ;;
  1573.         ;; Parent below and to right of child.
  1574.         ;;
  1575.         (ecase layout-style
  1576.           ((:vertical-tree :vertical-tree*)
  1577.            ;; Backlink.
  1578.            (setf parent-attachment
  1579.                  (add-points (node-placement-position (cdr pnode+placement))
  1580.                              (graph-node-left-center parent-struct)))
  1581.            (setf child-attachment
  1582.                  (add-points (node-placement-position (cdr cnode+placement))
  1583.                              (graph-node-right-center child-struct))))
  1584.           ((:horizontal-tree :horizontal-tree*)
  1585.            ;; Backlink.
  1586.            (setf parent-attachment
  1587.                  (add-points (node-placement-position (cdr pnode+placement))
  1588.                              (graph-node-top-center parent-struct)))
  1589.            (setf child-attachment
  1590.                  (add-points (node-placement-position (cdr cnode+placement))
  1591.                              (graph-node-bottom-center child-struct))))
  1592.           ((:radial :radial*)
  1593.            (case child-quadrant
  1594.              ((:upper :right)
  1595.               (setf parent-attachment
  1596.                     (add-points (node-placement-position (cdr pnode+placement))
  1597.                                 (graph-node-top-center parent-struct)))
  1598.               (setf child-attachment
  1599.                     (add-points (node-placement-position (cdr cnode+placement))
  1600.                                 (graph-node-bottom-center child-struct))))
  1601.              ((:lower :left)
  1602.               (setf parent-attachment
  1603.                     (add-points (node-placement-position (cdr pnode+placement))
  1604.                                 (graph-node-left-center parent-struct)))
  1605.               (setf child-attachment
  1606.                     (add-points (node-placement-position (cdr cnode+placement))
  1607.                                 (graph-node-right-center child-struct)))))))
  1608.         )
  1609.  
  1610.        (T 
  1611.         ;;
  1612.         ;; Parent centered under child.
  1613.         ;;
  1614.         (ecase layout-style
  1615.           ((:vertical-tree :vertical-tree*)
  1616.            ;; Backlink.
  1617.            (setf parent-attachment
  1618.                  (add-points (node-placement-position (cdr pnode+placement))
  1619.                              (graph-node-right-center parent-struct)))
  1620.            (setf child-attachment
  1621.                  (add-points (node-placement-position (cdr cnode+placement))
  1622.                              (graph-node-right-center child-struct))))
  1623.           ((:horizontal-tree :horizontal-tree* :radial :radial*)
  1624.            ;; Backlink-ish for horizontal.
  1625.            (setf parent-attachment
  1626.                  (add-points (node-placement-position (cdr pnode+placement))
  1627.                              (graph-node-top-center parent-struct)))
  1628.            (setf child-attachment
  1629.                  (add-points (node-placement-position (cdr cnode+placement))
  1630.                              (graph-node-bottom-center child-struct)))))
  1631.         )))
  1632.  
  1633.      (T
  1634.       (cond
  1635.  
  1636.        (parent-h-<-child-h?
  1637.         ;;
  1638.         ;; Parent on same level and to left of child.
  1639.         ;;
  1640.         (ecase layout-style
  1641.           ((:vertical-tree :vertical-tree*)
  1642.            ;; Backlink-ish for vertical styles.
  1643.            (setf parent-attachment
  1644.                  (add-points (node-placement-position (cdr pnode+placement))
  1645.                              (graph-node-bottom-center parent-struct)))
  1646.            (setf child-attachment
  1647.                  (add-points (node-placement-position (cdr cnode+placement))
  1648.                              (graph-node-bottom-center child-struct))))
  1649.           ((:horizontal-tree :horizontal-tree* :radial :radial*)
  1650.            (setf parent-attachment
  1651.                  (add-points (node-placement-position (cdr pnode+placement))
  1652.                              (graph-node-right-center parent-struct)))
  1653.            (setf child-attachment
  1654.                  (add-points (node-placement-position (cdr cnode+placement))
  1655.                              (graph-node-left-center child-struct)))))
  1656.         )
  1657.  
  1658.        (child-h-<-parent-h?
  1659.         ;;
  1660.         ;; Parent on same level and to right of child.
  1661.         ;;
  1662.         (ecase layout-style
  1663.           ((:vertical-tree :vertical-tree*)
  1664.            ;; Backlink-ish for vertical styles.
  1665.            (setf parent-attachment
  1666.                  (add-points (node-placement-position (cdr pnode+placement))
  1667.                              (graph-node-bottom-center parent-struct)))
  1668.            (setf child-attachment
  1669.                  (add-points (node-placement-position (cdr cnode+placement))
  1670.                              (graph-node-bottom-center child-struct))))
  1671.           ((:horizontal-tree :horizontal-tree*)
  1672.            ;; Backlink.
  1673.            (setf parent-attachment
  1674.                  (add-points (node-placement-position (cdr pnode+placement))
  1675.                              (graph-node-top-center parent-struct)))
  1676.            (setf child-attachment
  1677.                  (add-points (node-placement-position (cdr cnode+placement))
  1678.                              (graph-node-top-center child-struct))))
  1679.           ((:radial :radial*)
  1680.            (setf parent-attachment
  1681.                  (add-points (node-placement-position (cdr pnode+placement))
  1682.                              (graph-node-left-center parent-struct)))
  1683.            (setf child-attachment
  1684.                  (add-points (node-placement-position (cdr cnode+placement))
  1685.                              (graph-node-right-center child-struct)))))
  1686.         )
  1687.  
  1688.        (T 
  1689.         ;;
  1690.         ;; Nodes appear to be at same location!  Use default linkage for style.
  1691.         ;;
  1692.         (ecase layout-style
  1693.           ((:vertical-tree :vertical-tree*)
  1694.            (setf parent-attachment
  1695.                  (add-points (node-placement-position (cdr pnode+placement))
  1696.                              (graph-node-bottom-center parent-struct)))
  1697.            (setf child-attachment
  1698.                  (add-points (node-placement-position (cdr cnode+placement))
  1699.                              (graph-node-top-center child-struct))))
  1700.           ((:horizontal-tree :horizontal-tree*)
  1701.            (setf parent-attachment
  1702.                  (add-points (node-placement-position (cdr pnode+placement))
  1703.                              (graph-node-right-center parent-struct)))
  1704.            (setf child-attachment
  1705.                  (add-points (node-placement-position (cdr cnode+placement))
  1706.                              (graph-node-left-center child-struct))))
  1707.           ((:radial :radial*)
  1708.            (setf parent-attachment
  1709.                  (add-points (node-placement-position (cdr pnode+placement))
  1710.                              (graph-node-top-center parent-struct)))
  1711.            (setf child-attachment
  1712.                  (add-points (node-placement-position (cdr cnode+placement))
  1713.                              (graph-node-top-center child-struct)))))
  1714.         ))))
  1715.  
  1716.     ;; If connector requested, make blob to mark head of arc.
  1717.     (if (graph-node-connector (sm:gets 'graph-node (car cnode+placement)))
  1718.       (paint-oval (add-points (make-point (- *connector-radius*)
  1719.                                           (- *connector-radius*))
  1720.                               child-attachment)
  1721.                   (add-points (make-point *connector-radius* *connector-radius*)
  1722.                               child-attachment)))
  1723.  
  1724.     ;; Draw the line.
  1725.     (move-to parent-attachment)
  1726.     (line-to child-attachment)))
  1727.  
  1728. (defun DRAW-GRAPH-NODE (node+placement node-font)
  1729.   (declare (cons node+placement) (list node-font) 
  1730.            (optimize (safety 0) (space 2) (speed 3)))
  1731.   (let* ((node-struct (sm:gets 'graph-node (car node+placement)))
  1732.          (box-style (graph-node-box-style node-struct))
  1733.          (box-size (graph-node-box-size node-struct))
  1734.          (upper-left-corner-position
  1735.           (node-placement-position (cdr node+placement)))
  1736.          (lower-right-corner-position 
  1737.           (add-points upper-left-corner-position box-size)))
  1738.     (declare (type graph-node node-struct) (keyword box-style)
  1739.              (fixnum box-size upper-left-corner-position lower-right-corner-position))
  1740.  
  1741.     ;; White out underlying stuff according to the box style; Draw box outline.
  1742.     (set-pen-pattern *white-pattern*)
  1743.     (case box-style
  1744.       ((:none :none-frame)
  1745.        (paint-rect upper-left-corner-position lower-right-corner-position)
  1746.        (pen-normal))
  1747.       ((:rect :frame)
  1748.        (paint-rect upper-left-corner-position lower-right-corner-position)
  1749.        (pen-normal)
  1750.        (frame-rect upper-left-corner-position lower-right-corner-position))
  1751.       ((:round-rect :round-frame)
  1752.        (paint-round-rect
  1753.         (point-v box-size) ; oval width
  1754.         (point-v box-size) ; oval height
  1755.         upper-left-corner-position lower-right-corner-position)
  1756.        (pen-normal)
  1757.        (frame-round-rect 
  1758.         (point-v box-size)
  1759.         (point-v box-size)
  1760.         upper-left-corner-position lower-right-corner-position))
  1761.       ((:oval)
  1762.        (paint-oval upper-left-corner-position lower-right-corner-position)
  1763.        (pen-normal)
  1764.        (frame-oval upper-left-corner-position lower-right-corner-position)))
  1765.  
  1766.     ;; Write in label(s), with placement sensitive to size and style of box.
  1767.     (if (member box-style *framed-styles*)
  1768.       (do ((lptr (graph-node-label node-struct) (cdr lptr))
  1769.            (count 0 (1+ count))
  1770.            (line-height
  1771.             (multiple-value-bind (a d) (font-info node-font)
  1772.               (+ a d (if (< (second node-font) *small-font-threshold*) 
  1773.                        *small-font-box-height-padding*
  1774.                        *large-font-box-height-padding*)))))
  1775.           ((null lptr))
  1776.         (declare (list lptr) (fixnum count))
  1777.         (move-to (add-points
  1778.                   upper-left-corner-position  ; reference point
  1779.                   (make-point
  1780.                    (ecase box-style                         ; horizontal indentation
  1781.                      ((:frame :none-frame) *rect-text-h-indentation*)
  1782.                      ((:round-frame) *round-frame-text-h-indentation*))
  1783.                    (+ (if (< (second node-font) *small-font-threshold*)
  1784.                         *small-font-v-text-indentation*
  1785.                         *large-font-v-text-indentation*)    ; vertical indentation
  1786.                       (truncate (/ (float line-height) 2.0))
  1787.                       (* count line-height)))))
  1788.         (map nil #'stream-tyo (car lptr)))
  1789.       (progn 
  1790.         (move-to (add-points
  1791.                   upper-left-corner-position                   ; reference point
  1792.                   (make-point                                  ; indentation
  1793.                    (ecase box-style
  1794.                      ((:none :rect) *rect-text-h-indentation*)
  1795.                      ((:round-rect) *round-rect-text-h-indentation*)
  1796.                      ((:oval) *oval-text-h-indentation*))
  1797.                    (+ (if (< (second node-font) *small-font-threshold*) 
  1798.                         *small-font-v-text-indentation*
  1799.                         *large-font-v-text-indentation*)
  1800.                       (truncate (/ (float (point-v box-size)) 2.0))))))
  1801.         (map nil #'stream-tyo (graph-node-label node-struct))))))
  1802.  
  1803. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1804. ;;;
  1805. ;;;                       INTERACTIVE and I/O STUFF
  1806. ;;;
  1807. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1808.  
  1809. (defun GRAPH-VIEW-PARAMETER-DIALOGUE (label actual-roots graph-nodes
  1810.                                             &optional 
  1811.                                             (default-style :horizontal-tree*)
  1812.                                             (default-ordering :reduce-crossings)
  1813.                                             (default-depth  2))
  1814.   "graph-view-parameter-dialogue                                   [Function]
  1815.     <label> <actual-roots> <graph-nodes>
  1816.     &optional <default-style> <default-ordering> <default-depth>
  1817.   Uses a modal dialoge interaction to get and return as 4 multiple values 
  1818.   the Roots, Style, Ordering, and Depth parameters of a graph view. The
  1819.   required arguments are <label> to identify the graph view; <actual-roots>,
  1820.   the true roots (sources) of the graph (the user may elect to display from
  1821.   other sources); and <graph-nodes> a list of nodes in the graph, from which
  1822.   the user may choose alternate roots."
  1823.   (check-type actual-roots list)
  1824.   (check-type graph-nodes  list)
  1825.   (check-type default-style    keyword)
  1826.   (check-type default-ordering keyword)
  1827.   (check-type default-depth    fixnum)
  1828.  
  1829.   (let* 
  1830.     (
  1831.      (instructions
  1832.       (oneof
  1833.        *static-text-dialog-item*
  1834.        :dialog-item-position (make-point 10 5)
  1835.        :dialog-item-font '("chicago" 12)
  1836.        :dialog-item-text
  1837.        (format nil "Choose Graph View Parameters for ~S" label)))
  1838.      (top-labels 
  1839.       (oneof 
  1840.        *static-text-dialog-item*
  1841.        :dialog-item-position (make-point 10 30)
  1842.        :dialog-item-font '("chicago" 12)
  1843.        :dialog-item-text
  1844.        "Graph Roots                        Graph Depth"))
  1845.      (roots-menu
  1846.       (oneof
  1847.        *sequence-dialog-item*
  1848.        :dialog-item-size (make-point 150 168)
  1849.        :dialog-item-position (make-point 10 50)
  1850.        :table-vscrollp t
  1851.        :table-hscrollp nil
  1852.        :visible-dimensions (make-point 1 6)
  1853.        :cell-size (make-point 150 16)
  1854.        :table-sequence (if actual-roots 
  1855.                          (cons '|Use Actual Roots| graph-nodes)
  1856.                          graph-nodes)
  1857.        :sequence-order :vertical
  1858.        :selection-type :disjoint))
  1859.      (depth-menu
  1860.       (oneof 
  1861.        *sequence-dialog-item*
  1862.        :dialog-item-size (make-point 150 168)
  1863.        :dialog-item-position (make-point 190 50)
  1864.        :table-vscrollp t
  1865.        :table-hscrollp nil
  1866.        :visible-dimensions (make-point 1 6)
  1867.        :cell-size (make-point 150 16)
  1868.        :table-sequence (cons default-depth '(0 1 2 3 4 5 6 7 8 9 10 20 30 40 50))
  1869.        :sequence-order :vertical
  1870.        :selection-type :single))
  1871.      (bottom-labels 
  1872.       (oneof 
  1873.        *static-text-dialog-item*
  1874.        :dialog-item-position (make-point 10 160)
  1875.        :dialog-item-font '("chicago" 12)
  1876.        :dialog-item-text
  1877.        "Layout Style                        Child Ordering"))
  1878.      (style-menu
  1879.       (oneof 
  1880.        *sequence-dialog-item*
  1881.        :dialog-item-size (make-point 150 168)
  1882.        :dialog-item-position (make-point 10 180)
  1883.        :table-vscrollp t
  1884.        :table-hscrollp nil
  1885.        :visible-dimensions (make-point 1 6)
  1886.        :cell-size (make-point 150 16)
  1887.        ;; The slot type is specified with (member <object1> ... <objectN>)
  1888.        :table-sequence 
  1889.        (cons default-style
  1890.              (remove default-style 
  1891.                      (cddr (assoc 'style (sm:slot-types 'graph-view)))))
  1892.        :sequence-order :vertical
  1893.        :selection-type :single))
  1894.      (order-menu
  1895.       (oneof 
  1896.        *sequence-dialog-item*
  1897.        :dialog-item-size (make-point 150 168)
  1898.        :dialog-item-position (make-point 190 180)
  1899.        :table-vscrollp t
  1900.        :table-hscrollp nil
  1901.        :visible-dimensions (make-point 1 6)
  1902.        :cell-size (make-point 150 16)
  1903.        ;; The slot type is specified with (member <object1> ... <objectN>)
  1904.        :table-sequence 
  1905.        (cons default-ordering
  1906.              (remove default-ordering
  1907.                      (cddr (assoc 'ordering (sm:slot-types 'graph-view)))))
  1908.        :sequence-order :vertical
  1909.        :selection-type :single))
  1910.      (OK-button
  1911.       (oneof 
  1912.        *button-dialog-item*
  1913.        :dialog-item-text " OK "
  1914.        :dialog-item-position (make-point 380 75)
  1915.        :dialog-item-action
  1916.        #'(lambda ()
  1917.            (let ((roots (ask roots-menu (selected-cells)))
  1918.                  (style (ask style-menu (selected-cells)))
  1919.                  (order (ask order-menu (selected-cells)))
  1920.                  (depth (ask depth-menu (selected-cells))))
  1921.              (when (and roots style order depth)
  1922.                (return-from-modal-dialog
  1923.                 (values
  1924.                  (let ((chosen-roots 
  1925.                         (ask roots-menu (mapcar #'cell-contents roots))))
  1926.                    (if (member '|Use Actual Roots| chosen-roots)
  1927.                      (union actual-roots (delete '|Use Actual Roots| chosen-roots))
  1928.                      chosen-roots))
  1929.                  (ask style-menu (cell-contents (car style)))
  1930.                  (ask order-menu (cell-contents (car order)))
  1931.                  (ask depth-menu (cell-contents (car depth))))))
  1932.              (ed-beep)))
  1933.        :default-button t))
  1934.      (Cancel-button
  1935.       (oneof 
  1936.        *button-dialog-item*
  1937.        :dialog-item-text "CANCEL"
  1938.        :dialog-item-position (make-point 370 105)
  1939.        :dialog-item-action
  1940.        #'(lambda () (return-from-modal-dialog :cancel))))
  1941.      (the-dialogue
  1942.       (oneof *dialog*
  1943.                  :window-title (format nil "Graph View Parameters for ~A" label)
  1944.                  :window-size (make-point 440 290)
  1945.                  :window-position :centered
  1946.                  :window-show t
  1947.                  :window-type :double-edge-box
  1948.                  :dialog-items 
  1949.                  (list instructions top-labels bottom-labels 
  1950.                        roots-menu style-menu order-menu depth-menu 
  1951.                        ok-button cancel-button))))
  1952.     (ask roots-menu (when (table-sequence) (cell-select (index-to-cell 0))))
  1953.     (ask style-menu (when (table-sequence) (cell-select (index-to-cell 0))))
  1954.     (ask order-menu (when (table-sequence) (cell-select (index-to-cell 0))))
  1955.     (ask depth-menu (when (table-sequence) (cell-select (index-to-cell 0))))
  1956.     (modal-dialog the-dialogue)))
  1957.  
  1958. (defun SAVE-GRAPH-VIEW (graph-view path)
  1959.   "save-graph-view <graph-view>                                     [Function]
  1960.   Writes the macro definitions of <graph-view> and all its member
  1961.   graph-nodes to a file specified by <path>."
  1962.   (check-type graph-view symbol)
  1963.   (assert (sm:gets 'graph-view graph-view) (graph-view)
  1964.           "[GRAPHER:SAVE-GRAPH-VIEW] Unknown Graph-View ~S" graph-view)
  1965.   (check-type path (or simple-string pathname))
  1966.   (let ((*print-pretty* nil) (*print-escape* t)
  1967.         (*print-circle* nil) (*print-case* :upcase) (*print-array* t)
  1968.         #+:ccl (*print-structure* t)
  1969.         (graph-view-struct (sm:gets 'graph-view graph-view)))
  1970.     (declare (type graph-view graph-view-struct))
  1971.     (with-open-file (stream path
  1972.                             :direction :output
  1973.                             :if-exists :supersede)
  1974.       (format stream ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1975. ;;; Graph View ~S~%;;; Saved by SAVE-GRAPH-VIEW ~A~%;;; On the ~A"
  1976.               graph-view
  1977.               (multiple-value-bind
  1978.                 (second minute hour date month year)
  1979.                 (get-decoded-time)
  1980.                 (declare (integer second minute hour date month year))
  1981.                 (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
  1982.                         date 
  1983.                         (case month
  1984.                           ((1) "Jan") ((2) "Feb") ((3) "Mar") ((4) "Apr")
  1985.                           ((5) "May") ((6) "Jun") ((7) "Jul") ((8) "Aug")
  1986.                           ((9) "Sep") ((10) "Oct") ((11) "Nov") ((12) "Dec"))
  1987.                         (- year 1900)
  1988.                         hour minute second))
  1989.               (machine-type))
  1990.       (format stream "~%(in-package ~S)~%~%" (package-name *package*))
  1991.       (sm:prints 'graph-view graph-view 
  1992.                  :style :macro :stream stream
  1993.                  :omit '(mouse-methods))
  1994.       ;; Will have to do with the most basic mouse methods when restored.
  1995.       (format stream "~%~%(setf ~S~%      ~S)~%"
  1996.               `(graph-view-mouse-methods (sm:gets 'graph-view ',graph-view))
  1997.               (cdr (assoc 'mouse-methods (sm:slot-defaults 'graph-view))))
  1998.       (dolist (gn+p (graph-view-members graph-view-struct))
  1999.         (format stream "~%")
  2000.         (sm:prints 'graph-node (car gn+p) :style :macro :stream stream))
  2001.       (format stream "~&~%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2002. ;;; EOF"))
  2003.     path))
  2004.  
  2005. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2006. ;;; Graphing Arbitrary SM Objects
  2007.  
  2008. (defparameter *SM-MOUSE-METHODS*
  2009.   (append
  2010.    (list 
  2011.      (cons 
  2012.       "Make this Node the Root"
  2013.       (compile 
  2014.        nil 
  2015.        '(lambda (gw gv gn)
  2016.           (ccl:ask gw
  2017.                    (let* ((gv-struct (sm:gets 'graph-view gv))
  2018.                           (new-gv 
  2019.                            (sm-type->graph-view
  2020.                             (graph-view-info-image :sm-type gv)
  2021.                             (graph-view-info-image :access-slot gv)
  2022.                             (list (graph-node-object
  2023.                                    (sm:gets 'graph-node gn)))
  2024.                             (graph-view-info-image :child-access-p gv)
  2025.                             (graph-view-style gv-struct)
  2026.                             (graph-view-ordering gv-struct)
  2027.                             (graph-view-depth-bound gv-struct)
  2028.                             gv))) ; parent view
  2029.                      (set-graph-view new-gv)
  2030.                      (ccl:set-window-title 
  2031.                       (sm:prints 'graph-view new-gv 
  2032.                                  :style :name :stream nil))
  2033.                      (ccl:window-select)
  2034.                      (view-draw-contents))))))
  2035.  
  2036.      (cons
  2037.       "Backup Once to Parent View"
  2038.       (compile 
  2039.        nil 
  2040.        '(lambda (gw gv gn)            
  2041.           (declare (ignore gn))
  2042.           (ccl:ask gw
  2043.                    (let ((parent-view 
  2044.                           (graph-view-info-image :parent-view gv)))
  2045.                      (if parent-view
  2046.                        (if (sm:gets 'graph-view parent-view)
  2047.                          (progn
  2048.                            (set-graph-view parent-view :layout nil) ; already laid out
  2049.                            (ccl:set-window-title
  2050.                             (sm:prints 'graph-view parent-view
  2051.                                        :style :name :stream nil))
  2052.                            (ccl:window-select)
  2053.                            (view-draw-contents)
  2054.                            (unless (windows-using-graph-view gv)
  2055.                              (eval-enqueue `(dispose-graph-view ',gv))))
  2056.                          (progn 
  2057.                            (ccl:ed-beep)
  2058.                            (setf (graph-view-info-image :parent-view gv) nil)
  2059.                            (let ((wind:*dialogue-position* 
  2060.                                   (upper-left-popup-position gw)))
  2061.                              (wind:message-dialogue 
  2062.                               "The parent view appears to have been destroyed."))
  2063.                            ;; The graph-view of gw was set to nil since we 
  2064.                            ;; thought gv was to be replaced ... restore it.
  2065.                            (set-graph-view gv :layout nil)
  2066.                            (view-draw-contents)))
  2067.                        (progn (ccl:ed-beep)
  2068.                               (let ((wind:*dialogue-position* 
  2069.                                       (upper-left-popup-position gw)))
  2070.                                 (wind:message-dialogue 
  2071.                                  "This graph view has no parent view."))
  2072.                               (set-graph-view gv :layout nil)
  2073.                               (view-draw-contents)))))))) ; see comment above
  2074.      
  2075.      (cons 
  2076.       "New Window with this Node as Root"
  2077.       (compile
  2078.        nil
  2079.        '(lambda (gw gv gn)
  2080.           (let* ((type (graph-view-info-image :sm-type gv))
  2081.                  (gv-struct (sm:gets 'graph-view gv))
  2082.                  (roots 
  2083.                   (list (graph-node-object (sm:gets 'graph-node gn))))
  2084.                  (style       (graph-view-style gv-struct))
  2085.                  (ordering    (graph-view-ordering gv-struct))
  2086.                  (depth-bound (graph-view-depth-bound gv-struct)))
  2087.             (multiple-value-setq
  2088.              (roots style ordering depth-bound)
  2089.              (graph-view-parameter-dialogue
  2090.               type roots nil style ordering depth-bound))
  2091.             (ccl:oneof
  2092.              *graph-window*
  2093.              :graph-view
  2094.              (sm-type->graph-view type 
  2095.                                   (graph-view-info-image :access-slot gv)
  2096.                                   roots 
  2097.                                   (graph-view-info-image :child-access-p gv)
  2098.                                   style ordering depth-bound gv))))))
  2099.  
  2100.      (cons 
  2101.       "Backup All the Way to Original View"
  2102.       (compile 
  2103.        nil
  2104.        '(lambda (gw gv gn)            
  2105.           (declare (ignore gn))
  2106.           (ccl:ask gw
  2107.                    (let ((garbage-views nil) (original-view nil))
  2108.                      ;; Search up to find original view; also recording the views
  2109.                      ;; to be disposed of along the way. 
  2110.                      (do* ((parent-view 
  2111.                             (graph-view-info-image :parent-view gv)
  2112.                             (graph-view-info-image :parent-view current-view))
  2113.                            (current-view gv))
  2114.                           ;; Invariant here: parent-view is parent of current-view,
  2115.                           ;; so when parent-view nil, current-view is the root.
  2116.                           ((null parent-view) (setq original-view current-view))
  2117.                        (if (sm:gets 'graph-view parent-view)
  2118.                          (progn
  2119.                            (push current-view garbage-views)
  2120.                            (setq current-view parent-view))
  2121.                          (progn 
  2122.                            (ccl:ed-beep)
  2123.                            (setf (graph-view-info-image :parent-view current-view) nil)
  2124.                            (let ((wind:*dialogue-position* 
  2125.                                   (upper-left-popup-position gw)))
  2126.                              (wind:message-dialogue 
  2127.                               "The parent of view ~A appears to have been destroyed."
  2128.                               current-view))
  2129.                            (setq parent-view nil)))) ; to exit
  2130.                      (set-graph-view original-view :layout nil) ; already laid out
  2131.                      (ccl:set-window-title
  2132.                       (sm:prints 'graph-view original-view :style :name :stream nil))
  2133.                      (ccl:window-select)
  2134.                      (view-draw-contents)
  2135.                      (dolist (ggv garbage-views)
  2136.                        (unless (windows-using-graph-view ggv)
  2137.                          (eval-enqueue `(dispose-graph-view ',ggv)))))))))
  2138.      
  2139.      (cons 
  2140.       "Edit Associated Object"
  2141.       (compile 
  2142.        nil
  2143.        '(lambda (gw gv gn)
  2144.           (declare (ignore gw))
  2145.           (sm:edits (graph-view-info-image :sm-type gv)
  2146.                     (graph-node-object (sm:gets 'graph-node gn))))))
  2147.  
  2148.      (cons 
  2149.       "Update Graph View for Changes"
  2150.       (compile
  2151.        nil 
  2152.        '(lambda (gw gv gn)
  2153.           (declare (ignore gn))
  2154.           (let* ((gv-struct (sm:gets 'graph-view gv))
  2155.                  (type (graph-view-info-image :sm-type gv))
  2156.                  (access-slot (graph-view-info-image :access-slot gv))
  2157.                  (roots (graph-view-info-image :original-roots gv))
  2158.                  (child-access-p (graph-view-info-image :child-access-p gv))
  2159.                  (style       (graph-view-style gv-struct))
  2160.                  (ordering    (graph-view-ordering gv-struct))
  2161.                  (depth-bound (graph-view-depth-bound gv-struct))
  2162.                  (parent-view (graph-view-info-image :parent-view gv))
  2163.                  (new-view nil))
  2164.             (multiple-value-setq
  2165.              (roots style ordering depth-bound)
  2166.              (graph-view-parameter-dialogue type roots nil style ordering depth-bound))
  2167.             (ccl:ask gw
  2168.                      (set-graph-view nil)
  2169.                      (setq new-view 
  2170.                            (sm-type->graph-view 
  2171.                             type access-slot roots child-access-p 
  2172.                             style ordering depth-bound parent-view))
  2173.                      (unless (windows-using-graph-view gv) 
  2174.                        (eval-enqueue `(dispose-graph-view ',gv)))
  2175.                      (set-graph-view new-view)
  2176.                      (ccl:set-window-title
  2177.                       (sm:prints 'graph-view new-view :style :name :stream nil))
  2178.                      (ccl:window-select)
  2179.                      (view-draw-contents))))))
  2180.  
  2181.      (cons
  2182.       "Inspect Structure"
  2183.       (compile 
  2184.        nil
  2185.        '(lambda (gw gv gn)
  2186.           (inspect 
  2187.            (sm:gets (graph-view-info-image :sm-type gv)
  2188.                     (graph-node-object (sm:gets 'graph-node gn)))))))
  2189.  
  2190.      )
  2191.    ;; Note that SM stores unevaluated expressions producing defaults.
  2192.    (eval
  2193.     (cdr (assoc 'mouse-methods
  2194.                 (sm:slot-defaults 'graph-view))))))
  2195.     
  2196. (defun GRAPH-SM-OBJECTS (type access-slot roots
  2197.                               &optional (child-access-p t)
  2198.                                         (style :horizontal-tree*) 
  2199.                                         (ordering :reduce-crossings)
  2200.                                         (depth-bound 2)
  2201.                                         (label-function #'symbol-name))
  2202.   "graph-sm-objects <type> <access-slot> <roots>
  2203.           &optional <child-access-p> <style> <ordering> <depth-bound>
  2204.                     <label-function>
  2205.   <type> is an SM type; <roots> a list of instance names; <access-slot> the
  2206.   name of an SM slot; <child-access-p> (default t) is T if <access-slot> lists 
  2207.   child instances, and NIL if it lists parent instances (in which case computing
  2208.   graph members is slower); <depth-bound> defaults 2; <style> defaults 
  2209.   :horizontal-tree*, and <ordering> defaults :reduce-crossings.  <Label-function>
  2210.   defaults to SYMBOL-NAME, and should be a function of one argument mapping names
  2211.   of instances of <type> to string labels."
  2212.   (check-type type symbol)
  2213.   (check-type roots list)
  2214.   (check-type access-slot symbol)
  2215.   (check-type depth-bound fixnum)
  2216.   (check-type style keyword)
  2217.   (check-type ordering keyword)
  2218.   (check-type label-function function)
  2219.   (assert (member type (sm:structure-types)) (type) "Unknown type ~S" type)
  2220.   (dolist (i roots)
  2221.     (assert (sm:gets type i) (roots) "Unknown instance ~S" i))
  2222.   (assert (assoc access-slot (sm:slot-access type)) 
  2223.           (access-slot) 
  2224.           "Slot ~S is not defined for type ~S" access-slot type)
  2225.  
  2226.   ;; Get desired parameters.
  2227.   (multiple-value-setq
  2228.    (roots style ordering depth-bound)
  2229.    (graph-view-parameter-dialogue
  2230.     type roots (sm:instances type) style ordering depth-bound))
  2231.  
  2232.   ;; Make graph view and put up in window.
  2233.   (oneof *graph-window* 
  2234.          :graph-view
  2235.              (sm-type->graph-view
  2236.                type access-slot roots child-access-p style ordering depth-bound 
  2237.                nil label-function)))
  2238.  
  2239. (defun SM-TYPE->GRAPH-VIEW (type access-slot roots child-access-p 
  2240.                             &optional (style :horizontal-tree*) 
  2241.                                       (ordering :reduce-crossings) 
  2242.                                       (depth-bound 2) parent-view
  2243.                                       (label-function #'symbol-name))
  2244.   "sm-type->graph-view <type> <access-slot> <roots> <child-access-p>
  2245.                        &optional <style> <ordering> <depth-bound> <parent-view>
  2246.                                  <label-function>
  2247.   Returns a graph-view of instances of the SM type with the indicated parameters.  
  2248.   The optional <parent-view>, if given, should be a graph view, presumably one 
  2249.   containing as a node the root of the current view. <Label-function> is given
  2250.   a function of one argument which maps names of the instances of <type> to the
  2251.   label (string) to put on the graph node.  This is an 'internal' function which 
  2252.   does NO ARGUMENT CHECKING. "
  2253.   (declare (symbol type access-slot) (list roots) (keyword style ordering) 
  2254.            (fixnum depth-bound) (function label-function)
  2255.            (optimize (safety 1) (space 2) (speed 3)))
  2256.  
  2257.     (create-graph-view
  2258.      ;; Make unique name.  If root is unique, graph view is probably "about" that
  2259.      ;; root, so include it in name.  Othewise, just use type to generate name.
  2260.      (utils:unique-symbol
  2261.       (if (= (length roots) 1)
  2262.         (format nil "~A ~A " type (first roots))
  2263.         (format nil "~A " type)))
  2264.      ;; Roots argument to this function is list of SM instances.  Actual graph view
  2265.      ;; has graph-node instances as roots, returned by the call below.
  2266.      (make-view-nodes-returning-roots
  2267.       type access-slot roots child-access-p depth-bound parent-view label-function)
  2268.      depth-bound style ordering
  2269.      '("monaco" 9) '("chicago" 9) 10
  2270.      ;; Record this in INFO for use of mouse method.
  2271.      `((:sm-type . ,type) (:parent-view . ,parent-view)
  2272.        (:access-slot . ,access-slot) (:child-access-p . ,child-access-p)
  2273.        (:original-roots . ,roots))
  2274.      *sm-mouse-methods*))
  2275.  
  2276. (defun MAKE-VIEW-NODES-RETURNING-ROOTS (type access-slot roots 
  2277.                                              child-access-p depth-bound parent-view
  2278.                                              label-function)
  2279.   (declare (symbol type access-slot) (list roots) (fixnum depth-bound)
  2280.            (function label-function) (optimize (safety 1) (space 2) (speed 3)))
  2281.   
  2282.   ;; Complication: graph node names will not be the same as the instance names.
  2283.   ;; Mapping of instance names to graph nodes must be done before filling in 
  2284.   ;; child slots, so two passes needed.  Within each pass, some code is
  2285.   ;; duplicated based on whether access-slot is child-access-p.
  2286.   (let ((instance->graph-node nil)
  2287.         (access-function (cdr (assoc access-slot (sm:slot-access type)))))
  2288.     (declare (list instance->graph-node) (function access-function))
  2289.     
  2290.     ;; Iterate over successive frontiers of new reachable instances, making nodes.
  2291.     (do ((frontier roots)
  2292.          (new-frontier nil nil)
  2293.          (depth 0 (1+ depth)))
  2294.         ((or (null frontier) (> depth depth-bound)))
  2295.       (declare (list frontier))
  2296.       
  2297.       ;; Create a graph node for each instance, and expand the frontier.
  2298.       (dolist (fn frontier)
  2299.         (declare (symbol fn))
  2300.         (push (cons fn 
  2301.                     (create-graph-node (gensym "GRAPH-NODE-")
  2302.                                        (funcall label-function fn)
  2303.                                        nil         ; children (computed below)
  2304.                                        :rect       ; box-style default (may change)
  2305.                                        T           ; connector
  2306.                                        fn))        ; associated object
  2307.               instance->graph-node)
  2308.         
  2309.         ;; Put on new frontier those children we have not seen (unless past bound).
  2310.         (unless (= depth depth-bound)
  2311.           (if child-access-p
  2312.             (dolist (child (funcall access-function (sm:gets type fn)))
  2313.               (declare (symbol child))
  2314.               (if (not (assoc child instance->graph-node))
  2315.                 (push child new-frontier)))
  2316.             (dolist (i (sm:instances type)) ; searching for inverse links
  2317.               (declare (symbol i))
  2318.               (if (and (member fn (funcall access-function (sm:gets type i)))
  2319.                        (not (assoc i instance->graph-node)))
  2320.                 (push i new-frontier))))))
  2321.       (setf frontier new-frontier))
  2322.     
  2323.     ;; Second Pass: Now that all members are known, put in child info.
  2324.     ;; Box style becomes round-rect if child seen, to indicate subtree exists.
  2325.     (dolist (i+gn instance->graph-node)
  2326.       (declare (cons i+gn))
  2327.       (let ((children
  2328.              (if child-access-p
  2329.                (funcall access-function (sm:gets type (car i+gn)))
  2330.                (mapcan #'(lambda (i) ; searching for children again
  2331.                            (declare (symbol i))
  2332.                            (if (member (car i+gn)
  2333.                                        (funcall access-function (sm:gets type i)))
  2334.                              (list i)))
  2335.                        (sm:instances type)))))
  2336.         (declare (list children))
  2337.         (when children
  2338.           (setf (graph-node-box-style (sm:gets 'graph-node (cdr i+gn))) :round-rect)
  2339.           (dolist (child children)
  2340.             (declare (symbol child))
  2341.             ;; Filtering out children not in the graph view due to cutoff.
  2342.             (let ((child-graph-node (cdr (assoc child instance->graph-node))))
  2343.               (when child-graph-node
  2344.                 (push child-graph-node
  2345.                       (graph-node-children (sm:gets 'graph-node (cdr i+gn))))))))))
  2346.     
  2347.     ;; Return graph view roots (the images of root instances).
  2348.     (mapcar #'(lambda (ri)
  2349.                 (declare (symbol ri))
  2350.                 (let ((root (cdr (assoc ri instance->graph-node))))
  2351.                   (unless parent-view ; top level view roots are ovals
  2352.                     (setf (graph-node-box-style (sm:gets 'graph-node root)) :oval))
  2353.                   root))
  2354.             roots)))
  2355.  
  2356. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2357. ;;; CREATE MENU
  2358.  
  2359. (defparameter *GRAPHER-MENU*
  2360.   (let* 
  2361.     (
  2362.      (line-item
  2363.       (oneof *menu-item*
  2364.              :menu-item-title "-"))
  2365.  
  2366.      (new-window-item
  2367.       (oneof *menu-item*
  2368.              :menu-item-title "New Graph Window ..."
  2369.              :menu-item-action
  2370.              #'(lambda (&aux gw)
  2371.                  (setf gw
  2372.                        (oneof 
  2373.                         *graph-window*
  2374.                         :graph-view 
  2375.                         (wind:menu-dialogue
  2376.                          (cons NIL (sm:instances 'graph-view))
  2377.                          "Which graph view do you want in the Graph Window?")))
  2378.                  (ask gw (window-select))))) ; will layout and draw.
  2379.  
  2380.      (set-view-item
  2381.       (oneof *menu-item*
  2382.              :menu-item-title "Set Graph View ..."
  2383.              :menu-item-action
  2384.              #'(lambda ()
  2385.                  (let* ((graph-window-names
  2386.                          (mapcar #'(lambda (gw) (ask gw (window-title)))
  2387.                                  (windows *graph-window*)))
  2388.                         (graph-window
  2389.                          (utils:image 
  2390.                           (wind:menu-dialogue
  2391.                            graph-window-names
  2392.                            "Which window do you want to give a new Graph View?")
  2393.                           (pairlis graph-window-names (windows *graph-window*))))
  2394.                         (graph-view
  2395.                          (if graph-window
  2396.                            (wind:menu-dialogue
  2397.                             (cons NIL (sm:instances 'graph-view))
  2398.                             "Which graph view do you want ~A to have?" graph-window))))
  2399.                    ;; Give the window below the menu a chance to redraw before we
  2400.                    ;; start messing with the layout.  (Had a problem with :radial).
  2401.                    (sleep .5)
  2402.                    (ask graph-window 
  2403.                      (set-graph-view graph-view :layout t)
  2404.                      (view-draw-contents))))))
  2405.  
  2406.      (recompute-item
  2407.       (oneof *menu-item*
  2408.              :menu-item-title "ReCompute Layout..."
  2409.              :menu-item-action
  2410.              #'(lambda ()
  2411.                  (let* ((graph-window-names
  2412.                          (mapcar #'(lambda (gw) (ask gw (window-title)))
  2413.                                  (windows *graph-window*)))
  2414.                         (chosen-windows 
  2415.                          (wind:multiple-menu-dialogue
  2416.                           graph-window-names
  2417.                           "(Re)Compute layout of which graph view windows?"))
  2418.                         (window->object
  2419.                          (pairlis graph-window-names (windows *graph-window*))))
  2420.                    ;; Give the window below the menu a chance to redraw before we
  2421.                    ;; start messing with the layout.  (Had a problem with :radial).
  2422.                    (sleep .5)
  2423.                    (dolist (graph-window chosen-windows)
  2424.                      (ask (utils:image graph-window window->object)
  2425.                        (layout-graph-view) 
  2426.                        (view-draw-contents)))))))
  2427.  
  2428.      (change-view-parameters-item
  2429.       (oneof *menu-item*
  2430.              :menu-item-title "Change View Parameters..."
  2431.              :menu-item-action
  2432.              #'(lambda ()
  2433.                  (let* ((graph-view
  2434.                         (wind:menu-dialogue
  2435.                          (sm:instances 'graph-view) 
  2436.                          "Which graph view do you wish to change the parameters of?"))
  2437.                         (graph-view-itself (sm:gets 'graph-view graph-view)))
  2438.                    (multiple-value-bind
  2439.                      (roots style ordering depth-bound)
  2440.                      (graph-view-parameter-dialogue
  2441.                       graph-view
  2442.                       (graph-view-roots graph-view-itself)
  2443.                       (mapcar #'car (graph-view-members graph-view-itself)))
  2444.                      ;; Give the window below the menu a chance to redraw before we
  2445.                      ;; start messing with the layout.  (Had a problem with :radial).
  2446.                      (sleep .5)
  2447.                      (setf (graph-view-roots       graph-view-itself) roots)
  2448.                      (setf (graph-view-style       graph-view-itself) style)
  2449.                      (setf (graph-view-ordering    graph-view-itself) ordering)
  2450.                      (setf (graph-view-depth-bound graph-view-itself) depth-bound))))))
  2451.  
  2452.      (list-windows-using-item
  2453.       (oneof *menu-item*
  2454.              :menu-item-title "Windows Using View..."
  2455.              :menu-item-action
  2456.              #'(lambda ()
  2457.                  (let* ((graph-view
  2458.                         (wind:menu-dialogue
  2459.                          (sm:instances 'graph-view) 
  2460.                          "For which graph view do you want a list of windows using it?"))
  2461.                         (active-windows (windows-using-graph-view graph-view)))
  2462.                    (if active-windows
  2463.                      (wind:menu-dialogue 
  2464.                       (mapcar #'(lambda (w) (ask w (window-title))) active-windows)
  2465.                       "These windows are still using ~S"
  2466.                       graph-view)
  2467.                      (wind:message-dialogue "No windows are using ~S" graph-view))))))
  2468.  
  2469.      (dispose-graph-view-item
  2470.       (oneof *menu-item*
  2471.              :menu-item-title "Dispose Graph Views..."
  2472.              :menu-item-action
  2473.              #'(lambda ()
  2474.                  (dolist (graph-view
  2475.                           (wind:multiple-menu-dialogue
  2476.                            (sm:instances 'graph-view) 
  2477.                            "Dispose of which graph views?"))
  2478.                    ;; Give the window below the menu a chance to redraw before we
  2479.                    ;; start messing with the layout.  (Had a problem with :radial).
  2480.                    (sleep .5)
  2481.                    (unless (windows-using-graph-view graph-view)
  2482.                      (eval-enqueue `(dispose-graph-view ',graph-view)))))))
  2483.  
  2484.      (save-item
  2485.       (oneof *menu-item*
  2486.              :menu-item-title "Save Graph View ..."
  2487.              :menu-item-action
  2488.              #'(lambda ()
  2489.                  (let* ((gv (wind:menu-dialogue
  2490.                              (sm:instances 'graph-view)
  2491.                              "Which graph view do you want to save?~%(MOUSE-METHODS are NOT saved.)"))
  2492.                         (file-path
  2493.                          (pathname 
  2494.                           (choose-new-file-dialog
  2495.                            :prompt 
  2496.                            (format nil "Save ~A to ..." gv))))
  2497.                         (backup-path
  2498.                          (make-pathname
  2499.                           :host      (pathname-host file-path)
  2500.                           :device    (pathname-device file-path)
  2501.                           :directory (pathname-directory file-path)
  2502.                           :name      (pathname-name file-path)
  2503.                           :type      "bak")))
  2504.                    (if (probe-file file-path)
  2505.                      (progn
  2506.                        (if (probe-file backup-path)
  2507.                          (delete-file backup-path))
  2508.                        (rename-file file-path backup-path)
  2509.                        (format T "~&;~A backed up to ~A" 
  2510.                                (namestring file-path)
  2511.                                (namestring backup-path))))
  2512.                    (setf *default-instance-file-path*
  2513.                          (directory-namestring file-path))
  2514.                    (save-graph-view gv file-path)
  2515.                    (format T "~&;Graph View ~A saved to ~S"
  2516.                            gv
  2517.                            (namestring file-path))))))
  2518.  
  2519.      (sm-graph-item
  2520.       (oneof *menu-item*
  2521.              :menu-item-title "Graph SM Objects ..."
  2522.              :menu-item-action
  2523.              #'(lambda ()
  2524.                  (let* ((type 
  2525.                          (wind:menu-dialogue (sm:structure-types)
  2526.                                              "Graph instances of which type?"))
  2527.                         (slot
  2528.                          (or (sm:type-info type :graph-view-child-slot)
  2529.                              (sm:type-info type :graph-view-parent-slot)
  2530.                              (wind:menu-dialogue 
  2531.                               (mapcar #'car (sm:slot-access type))
  2532.                               "Which slot of ~A holds the child or parent relation?"
  2533.                               type)))
  2534.                         (child-p
  2535.                          (cond ((sm:type-info type :graph-view-child-slot) T)
  2536.                                ((sm:type-info type :graph-view-parent-slot) nil)
  2537.                                (T (wind:y-or-n-dialogue "Is this a child relation slot?")))))
  2538.                    (if (sm:instances type)
  2539.                      (graph-sm-objects 
  2540.                       type slot (sm:type-info type :graph-view-roots) child-p)
  2541.                      (wind:message-dialogue
  2542.                       "There are no instances of ~S to graph." type))))))
  2543.  
  2544.      (deinstall-item
  2545.       (oneof *menu-item*
  2546.              :menu-item-title "Hide This Menu"
  2547.              :menu-item-action 
  2548.              '(ask *grapher-menu* (menu-deinstall))))
  2549.  
  2550.      (grapher-menu (oneof *menu*
  2551.                           :menu-title "Grapher"
  2552.                           :menu-items (list new-window-item
  2553.                                             recompute-item
  2554.                                             set-view-item
  2555.                                             line-item
  2556.                                             change-view-parameters-item
  2557.                                             list-windows-using-item
  2558.                                             save-item
  2559.                                             dispose-graph-view-item
  2560.                                             line-item
  2561.                                             sm-graph-item
  2562.                                             line-item
  2563.                                             deinstall-item))))
  2564.     (ask grapher-menu (menu-install))
  2565.     (ask line-item (menu-item-disable))
  2566.     ;; Menu-dispose dumped from version 1.3.1?
  2567.     (if (and (boundp '*grapher-menu*) 
  2568.              (typep *grapher-menu* *menu*))
  2569.       (ask *grapher-menu* (menu-deinstall)))
  2570.     grapher-menu))
  2571.  
  2572. (ask *tools-menu*
  2573.   (add-menu-items
  2574.    (oneof *menu-item*
  2575.           :menu-item-title "Restore Grapher Menu"
  2576.           :menu-item-action
  2577.           #'(lambda ()
  2578.               (ask *grapher-menu*
  2579.                 (unless (menu-installed-p) (menu-install)))))))
  2580.  
  2581. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2582. (provide :grapher)
  2583. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2584. ;;; EOF